{-# LANGUAGE Arrows #-} module Parser (playerInput, shouldContinue, gameKeysSF, GameInput, Input, TimerEvent (..), waitForSpaceKey) where import Data.Maybe import Control.Monad (when) import Control.Monad.Loops (unfoldWhileM) import FRP.Yampa import FRP.Yampa.Geometry import Physics import Command import Data.FSM import Global import BasicTypes import Helper -- ************************************************************************* -- -- 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 elem key keys then Just (Up, key, checkModifiers mods) else Nothing RSKeyDown key mods -> if elem key 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 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