{-# LANGUAGE Arrows #-} module Parser (playerInput, shouldContinue, gameKeysSF, GameInput, Input, TimerEvent (..), waitForSpaceKey) where import Data.Maybe import Control.Monad (when) import FRP.Yampa import FRP.Yampa.Geometry import Physics import Command import Data.FSM import Global import BasicTypes -- ************************************************************************* -- -- Various type abbreviations -- -- ************************************************************************* data Trigger = OnUp | OnDown type KeyFSM = FSM String -- Just the state's name, only for debugging (KeyAction, RSKey, Shifted) -- Transition is directe by the action (Up or Down), -- The key (a, s, ...) and the information whether -- The shift key was held down during release (StateTime, (CurrentTime, StateTime)) -- Whoa, that's kind of messy: first StateTime indicates -- the time when the current state was entered, the CurrentTime -- is - well - the current time, and the second StateTime indicates -- the time the previous state was entered. since we wish to -- calculate the duration a key was pressed, we need the time difference -- between the current time and the time the previous state -- (that would have been the "Key Down"-state) was entered. The -- first StateTime is ignored. [Command] -- Resulting command list. Will be only one, but needs to be a Monoid, -- so probably Maybe Command should also work? type KeyState = State String (KeyAction, RSKey, Shifted) (StateTime, (CurrentTime, StateTime)) [Command] -- ************************************************************************* -- -- FSM for parsing mouse motion -- -- ************************************************************************* mousePos :: Param -> Position2 -> SF Input Position2 mousePos param pInit = proc (_,(_,input)) -> do let me = mouseEvent param input p <- hold pInit -< me returnA -< p mouseEvent :: Param -> [RSEvent] -> Event Position2 mouseEvent _ [] = NoEvent mouseEvent param (e:es) = case e of RSMouseMotion x y -> Event (Point2 x y) _ -> mouseEvent param es mouseCommand :: [RSEvent] -> [Command] mouseCommand [] = [] mouseCommand (e:es) = case e of RSMouseButtonDownLeft -> [CmdTakeOver] RSMouseButtonDownRight -> [] _ -> mouseCommand es -- ************************************************************************* -- -- FSM for parsing single keys (action on key-up) -- -- ************************************************************************* singleKeyCommand :: KeyFSM -> KeyState -> SF (CurrentTime, Event ([(KeyAction, RSKey, Shifted)], StateTime)) [Command] singleKeyCommand fsm initState = proc event' -> do ((_,_),command) <- reactMachineHist fsm initState 0 -< event' returnA -< command data KeyAction = Up | Down deriving (Ord, Eq, Show) data Shifted = Shifted | Unshifted deriving (Ord, Eq, Show) newKeyOnUpFSM :: RSKey -> Command -> Command -> (KeyFSM, KeyState) newKeyOnUpFSM key commandShifted commandUnshifted = let onEnterSmA (_, (p, sOld)) = [commandShifted {dt = p-sOld}] onEnterGrA (_, (p, sOld)) = [commandUnshifted {dt = p-sOld}] s0 = addTransition (Down, key, Unshifted) 1 $ addTransition (Down, key, Shifted) 1 $ state 0 "start" (const []) (const []) (const []) s1 = addTransition (Up, key, Unshifted) 2 $ addTransition (Up, key, Shifted) 3 $ state 1 "down" (const []) (const []) (const []) s2 = addTransition (Down, key, Shifted) 1 $ addTransition (Down, key, Unshifted) 1 $ state 2 "up" (const []) onEnterSmA (const []) s3 = addTransition (Down, key, Shifted) 1 $ addTransition (Down, key, Unshifted) 1 $ state 3 "UP" (const []) onEnterGrA (const []) Right fsm = fromList [s0, s1, s2, s3] in (fsm, s0) newKeyOnDownFSM :: RSKey -> Command -> Command -> (KeyFSM, KeyState) newKeyOnDownFSM key commandShifted commandUnshifted = let onEnterSmA _ = [commandShifted] onEnterGrA _ = [commandUnshifted] s0 = addTransition (Down, key, Unshifted) 1 $ addTransition (Down, key, Shifted) 2 $ state 0 "start" (const []) (const []) (const []) s1 = addTransition (Down, key, Shifted) 2 $ addTransition (Down, key, Unshifted) 1 $ state 1 "up" (const []) onEnterSmA (const []) s2 = addTransition (Down, key, Shifted) 2 $ addTransition (Down, key, Unshifted) 1 $ state 2 "UP" (const []) onEnterGrA (const []) Right fsm = fromList [s0, s1, s2] in (fsm, s0) keySF :: (t -> t1 -> a -> (KeyFSM, KeyState)) -> t -> t1 -> a -> SF (CurrentTime, Event ([(KeyAction, RSKey, Shifted)], StateTime)) [Command] keySF newKeyFSM key commandShifted = uncurry singleKeyCommand . newKeyFSM key commandShifted mapKeyEvent :: [RSKey] -> RSEvent -> Maybe (KeyAction, RSKey, Shifted) mapKeyEvent keys rse = case rse of RSKeyUp key mods -> if key `elem` keys then Just (Up, key, checkModifiers mods) else Nothing RSKeyDown key mods -> if key `elem` keys then Just (Down, key, checkModifiers mods) else Nothing _ -> Nothing -- mapKeyEvent keys (RSKeyUp key mods) = if elem key keys then Just (Up, key, checkModifiers mods) else Nothing -- mapkeyevent keys (RSKeyDown key mods) = if elem key keys then Just (Down, key, checkModifiers mods) else Nothing -- mapKeyEvent _ _ = Nothing checkModifiers :: [RSModifier] -> Shifted checkModifiers mods = if elem RSKeyModLeftShift mods || elem RSKeyModRightShift mods || elem RSKeyModShift mods then Shifted else Unshifted -- ************************************************************************* -- -- FSM for parsing multiple keys -- -- ************************************************************************* keyCommandSF' :: [(RSKey, Trigger, (Command, Command))] -> SF (CurrentTime, Event ([(KeyAction, RSKey, Shifted)], StateTime)) [Command] keyCommandSF' keys = let fsms = map (\(sdlKey, trigger, (cShifted, cUnshifted)) -> case trigger of OnDown -> keySF newKeyOnDownFSM sdlKey cShifted cUnshifted _ -> keySF newKeyOnUpFSM sdlKey cShifted cUnshifted) keys in concat ^<< parB fsms -- not really efficient, could also broadcast only those messages that -- are of interest to a given FSM keyCommandSF :: [(RSKey, Trigger, (Command, Command))] -> SF Input [Command] keyCommandSF keysCommands = proc (_, (gametime, input)) -> do let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_a, RSK_s, RSK_d, RSK_e, RSK_w, RSK_q, RSK_c, RSK_SPACE, RSK_ESCAPE, RSK_f]) input let keyEvents = if null keys then NoEvent else Event (keys, gametime) result <- keyCommandSF' keysCommands -< (gametime, keyEvents) returnA -< result -- ************************************************************************* -- -- FSM for player commands -- -- ************************************************************************* -- Caution: When adding more commands, remember to put the additional key in keyCommandSF!! playerKeysSF :: SF Input [Command] playerKeysSF = keyCommandSF [(RSK_a, OnUp, (CmdPassLow 0, CmdPassHigh 0)), (RSK_d, OnDown, (CmdFlipLow, CmdFlipHigh)), (RSK_e, OnDown, (CmdMoveForward, CmdMoveBackward)), (RSK_w, OnDown, (CmdMoveLeft, CmdMoveRight)), (RSK_q, OnDown, (CmdMoveToGoal, CmdMoveToMe)), (RSK_s, OnUp, (CmdKickLow 0, CmdKickHigh 0)), (RSK_c, OnDown, (CmdFlipMeLow, CmdFlipMeHigh)), (RSK_SPACE, OnDown, (CmdToggleFoot, CmdToggleFoot))] -- ************************************************************************* -- -- FSM for game commands -- -- ************************************************************************* -- Caution: When adding more commands, remember to put the additional key in keyCommandSF!! gameKeysSF :: SF Input [Command] gameKeysSF = keyCommandSF [(RSK_ESCAPE, OnDown, (CmdQuit, CmdQuit)), (RSK_f, OnDown, (CmdFreeze, CmdFreeze))] playerInput :: Param -> Position2 -> SF Input (Position2, [Command]) playerInput param p0 = proc gi@(_,(_,incoming)) -> do pd <- mousePos param p0 -< gi commands <- playerKeysSF -< gi let allCommands = mouseCommand incoming ++ commands returnA -< (pd, allCommands) -- ************************************************************************* -- -- some functions for basic game control -- -- ************************************************************************* waitForSpaceKey :: IO () waitForSpaceKey = do -- events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent let events = [] let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_SPACE]) events when (null keys) waitForSpaceKey shouldContinue :: IO Bool shouldContinue = do -- events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent let events = [] let yess = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_y]) events let nos = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_n]) events if null $ yess ++ nos then shouldContinue else return $ null nos