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