some more keyboard interaction
This commit is contained in:
parent
aed0732d3e
commit
7aa691bf87
1 changed files with 14 additions and 0 deletions
14
src/Main.hs
14
src/Main.hs
|
@ -57,6 +57,8 @@ pre = do
|
|||
let Subsystems w m k = subsystems ud
|
||||
_ <- partSubscribe w (fitViewport (1280/720))
|
||||
_ <- partSubscribe w exitOnWindowClose
|
||||
_ <- partSubscribe k toggleFullScreen
|
||||
_ <- partSubscribe k quitGame
|
||||
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
||||
putAffection ud
|
||||
{ threadContext = Just threadCtx
|
||||
|
@ -64,6 +66,18 @@ pre = do
|
|||
, worldState = ws
|
||||
}
|
||||
|
||||
quitGame :: KeyboardMessage -> Affection UserData ()
|
||||
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
|
||||
| otherwise = return ()
|
||||
quitGame _ = return ()
|
||||
|
||||
toggleFullScreen :: KeyboardMessage -> Affection UserData ()
|
||||
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
||||
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
|
||||
| otherwise = return ()
|
||||
toggleFullScreen _ = return ()
|
||||
|
||||
update :: Double -> Affection UserData ()
|
||||
update dt = do
|
||||
ud <- getAffection
|
||||
|
|
Loading…
Reference in a new issue