module FWGL.Input (
module FWGL.Key,
keyUp,
keyDown,
key,
mouseDown,
mouseUp,
mouse,
click,
mouseMove,
pointer,
resize,
size,
custom,
Input(..),
InputEvent(..),
EventData(..),
) where
import Data.Maybe
import Data.Hashable
import qualified Data.HashMap.Strict as H
import FWGL.Key
import FRP.Yampa
data InputEvent = KeyUp | KeyDown | MouseUp | MouseDown | MouseMove | Resize
deriving (Show, Eq, Enum)
data EventData = EventData {
dataFramebufferSize :: Maybe (Int, Int),
dataPointer :: Maybe (Int, Int),
dataButton :: Maybe MouseButton,
dataKey :: Maybe Key,
dataTime :: Double
}
data Input a = Input {
inputEvents :: H.HashMap InputEvent [EventData],
inputCustom :: a
}
instance Hashable InputEvent where
hashWithSalt salt = hashWithSalt salt . fromEnum
keyUp :: Key -> SF (Input a) (Event ())
keyUp k = evEdge KeyUp $ isKey k
keyDown :: Key -> SF (Input a) (Event ())
keyDown k = evEdge KeyDown $ isKey k
key :: Key -> SF (Input a) (Event ())
key k = sscan upDown NoEvent <<<
evEdgeTime KeyUp (isKey k) &&& evEdgeTime KeyDown (isKey k)
mouseDown :: MouseButton -> SF (Input a) (Event (Int, Int))
mouseDown b = evEdgePointer MouseDown (isButton b) >>^ fmap snd
mouseUp :: MouseButton -> SF (Input a) (Event (Int, Int))
mouseUp b = evEdgePointer MouseUp (isButton b) >>^ fmap snd
mouse :: MouseButton -> SF (Input a) (Event (Int, Int))
mouse b = sscan upDown NoEvent <<< evEdgePointer MouseUp (isButton b) &&&
evEdgePointer MouseDown (isButton b)
click :: SF (Input a) (Event (Int, Int))
click = mouseDown MouseLeft
mouseMove :: SF (Input a) (Event (Int, Int))
mouseMove = evPointer MouseMove (const True)
pointer :: SF (Input a) (Int, Int)
pointer = mouseMove >>> hold (0, 0)
resize :: SF (Input a) (Event (Int, Int))
resize = evSearch Resize (isJust . dataFramebufferSize) >>^
fmap (fromJust . dataFramebufferSize)
size :: SF (Input a) (Int, Int)
size = resize >>> hold (0, 0)
custom :: SF (Input a) a
custom = arr inputCustom
upDown :: Show a => Event a -> (Event (Double, a), Event (Double, a)) -> Event a
upDown _ (NoEvent, Event (_, x)) = Event x
upDown _ (Event _, NoEvent) = NoEvent
upDown _ (Event (t, _), Event (t', x)) | t' > t = Event x
| otherwise = noEvent
upDown e _ = e
isKey :: Key -> EventData -> Bool
isKey k ed = dataKey ed == Just k
isButton :: MouseButton -> EventData -> Bool
isButton btn evData = dataButton evData == Just btn
evSearch :: InputEvent -> (EventData -> Bool) -> SF (Input a) (Event EventData)
evSearch ev bP = arr $ \inp -> case H.lookup ev $ inputEvents inp of
Just bs -> eventHead $ filter bP bs
Nothing -> NoEvent
evEdge :: InputEvent -> (EventData -> Bool) -> SF (Input a) (Event ())
evEdge ev bP = (evSearch ev bP >>^ isEvent) >>> edge
evEdgeData :: InputEvent -> (EventData -> Bool)
-> SF (Input a) (Event EventData)
evEdgeData ev bP = (evSearch ev bP >>^ event Nothing Just) >>> edgeJust
evEdgeTime :: InputEvent -> (EventData -> Bool)
-> SF (Input a) (Event (Double, ()))
evEdgeTime ev bP = evEdgeData ev bP >>^ fmap (flip (,) () . dataTime)
evEdgePointer :: InputEvent -> (EventData -> Bool)
-> SF (Input a) (Event (Double, (Int, Int)))
evEdgePointer ev bP = evEdgeData ev bP >>^ \med ->
case med of
Event ed ->
case dataPointer ed of
Just ptr -> Event (dataTime ed, ptr)
Nothing -> NoEvent
NoEvent -> NoEvent
evPointer :: InputEvent -> (EventData -> Bool)
-> SF (Input a) (Event (Int, Int))
evPointer ev bP = evSearch ev bP >>^ \e ->
case e of
Event ed -> case dataPointer ed of
Just ptr -> Event ptr
_ -> NoEvent
NoEvent -> NoEvent
eventHead :: [a] -> Event a
eventHead [] = NoEvent
eventHead (x : _) = Event x