{-# 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