{-# LANGUAGE Arrows #-} module Parser (playerInput, shouldContinue, gameKeysSF, GameInput, Input, TimerEvent (..), waitForSpaceKey) where import qualified Graphics.UI.SDL as SDL import Graphics.UI.SDL.Keysym import Data.Maybe import Control.Monad (when) import Control.Monad.Loops (unfoldWhileM) import FRP.Yampa import FRP.Yampa.Geometry import RenderUtil 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, SDL.SDLKey, 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, SDL.SDLKey, 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 -> [SDL.Event] -> Event Position2 mouseEvent _ [] = NoEvent mouseEvent param (e:es) = case e of SDL.MouseMotion x y _ _ -> let (x', y') = pointToPitch param (fromIntegral x, fromIntegral y) in Event (Point2 x' y') _ -> mouseEvent param es mouseCommand :: [SDL.Event] -> [Command] mouseCommand [] = [] mouseCommand (e:es) = case e of SDL.MouseButtonDown _ _ SDL.ButtonLeft -> [CmdTakeOver] SDL.MouseButtonDown _ _ SDL.ButtonRight -> [] _ -> mouseCommand es -- ************************************************************************* -- -- FSM for parsing single keys (action on key-up) -- -- ************************************************************************* singleKeyCommand :: KeyFSM -> KeyState -> SF (CurrentTime, Event ([(KeyAction, SDL.SDLKey, 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 :: SDL.SDLKey -> 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 :: SDL.SDLKey -> 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, SDLKey, Shifted)], StateTime)) [Command] keySF newKeyFSM key commandShifted = uncurry singleKeyCommand . newKeyFSM key commandShifted mapKeyEvent :: [SDL.SDLKey] -> SDL.Event -> Maybe (KeyAction, SDL.SDLKey, Shifted) mapKeyEvent keys (SDL.KeyUp (SDL.Keysym key mods _)) = if elem key keys then Just (Up, key, checkModifiers mods) else Nothing mapKeyEvent keys (SDL.KeyDown (SDL.Keysym key mods _)) = if elem key keys then Just (Down, key, checkModifiers mods) else Nothing mapKeyEvent _ _ = Nothing checkModifiers :: [Modifier] -> Shifted checkModifiers mods = if elem SDL.KeyModLeftShift mods || elem SDL.KeyModRightShift mods || elem SDL.KeyModShift mods then Shifted else Unshifted -- ************************************************************************* -- -- FSM for parsing multiple keys -- -- ************************************************************************* keyCommandSF' :: [(SDL.SDLKey, Trigger, (Command, Command))] -> SF (CurrentTime, Event ([(KeyAction, SDL.SDLKey, 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 :: [(SDL.SDLKey, Trigger, (Command, Command))] -> SF Input [Command] keyCommandSF keysCommands = proc (_, (gametime, input)) -> do let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_a, SDL.SDLK_s, SDL.SDLK_d, SDL.SDLK_e, SDL.SDLK_w, SDL.SDLK_q, SDL.SDLK_c, SDL.SDLK_SPACE, SDL.SDLK_ESCAPE, SDL.SDLK_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 [(SDL.SDLK_a, OnUp, (CmdPassLow 0, CmdPassHigh 0)), (SDL.SDLK_d, OnDown, (CmdFlipLow, CmdFlipHigh)), (SDL.SDLK_e, OnDown, (CmdMoveForward, CmdMoveBackward)), (SDL.SDLK_w, OnDown, (CmdMoveLeft, CmdMoveRight)), (SDL.SDLK_q, OnDown, (CmdMoveToGoal, CmdMoveToMe)), (SDL.SDLK_s, OnUp, (CmdKickLow 0, CmdKickHigh 0)), (SDL.SDLK_c, OnDown, (CmdFlipMeLow, CmdFlipMeHigh)), (SDL.SDLK_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 [(SDL.SDLK_ESCAPE, OnDown, (CmdQuit, CmdQuit)), (SDL.SDLK_f, OnDown, (CmdFreeze, CmdFreeze))] playerInput :: Param -> SF Input (Position2, [Command]) playerInput param = proc gi@(_,(_,incoming)) -> do pd <- mousePos param (Point2 0 0) -< 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 keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_SPACE]) events when (null keys) waitForSpaceKey shouldContinue :: IO Bool shouldContinue = do events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent let yess = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_y]) events let nos = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_n]) events if null $ yess ++ nos then shouldContinue else return $ null nos