Overhaul event handling

src/Game/Display.hs

@@ -14,16 +14,16 @@ import Game.Utils
 import Graphics.Gloss
 import Graphics.Gloss.Interface.IO.Game
 
-getSquare :: (Int, Int) -> Picture
+getSquare :: (Int, Int) -> (Int, Int) -> Picture
-getSquare (toEnum -> x, toEnum -> y) =
+getSquare (toEnum -> winWidth, toEnum -> winHeight) (toEnum -> x, toEnum -> y) =
-  translate (x * 25) (y * 25) $ rectangleSolid 25 25
+  translate (x * winWidth / 30) (y * winHeight / 20) $ rectangleSolid (winWidth / 30) (winHeight / 20)
 
-displayState :: Monad m => MSF (DrawerT m) GameState ()
+displayState :: Monad m => MSF (DrawerT m) (GameState, (Int, Int)) ()
-displayState = proc state -> do
+displayState = proc (state, windowSize) -> do
-  draw -< pictures $ color green . getSquare <$> state.snakePos
+  draw -< pictures $ color green . getSquare windowSize <$> state.snakePos
-  draw -< color red $ getSquare state.berryPos
+  draw -< color red $ getSquare windowSize state.berryPos
 
-displayPause :: Monad m => MSF (DrawerT m) () ()
+displayPause :: Monad m => MSF (DrawerT m) (Int, Int) ()
-displayPause = proc () -> do
+displayPause = proc (width, height) -> do
-  draw -< color (withAlpha 0.5 black) $ rectangleSolid 5000 5000
+  draw -< color (withAlpha 0.5 black) $ rectangleSolid (toEnum width) (toEnum height)
   draw -< color white $ scale 0.5 0.5 $ text "Paused"

src/Game/Engine.hs

@@ -17,29 +17,12 @@ import Game.State
 import Game.Utils
 import Graphics.Gloss
 import Graphics.Gloss.Interface.IO.Game
+import Control.Applicative (asum)
 
 -- * Input handling
 
-getKeys :: Monad m => MSF (DrawerT m) () [Key]
+handleEvents :: Monad m => MSF (DrawerT m) () GameEvents
-getKeys = mapMaybe getKey <$> liftTransS (constM ask)
+handleEvents = parseEvents <$> liftTransS (constM ask)
-  where
-    getKey :: Event -> Maybe Key
-    getKey (EventKey k Down _ _) = Just k
-    getKey _ = Nothing
-
-handleEvents :: Monad m => MSF (DrawerT m) () [Direction]
-handleEvents = mapMaybe getDir <$> getKeys
-  where
-    getDir :: Key -> Maybe Direction
-    getDir (Char 'w') = Just U
-    getDir (Char 's') = Just D
-    getDir (Char 'a') = Just L
-    getDir (Char 'd') = Just R
-    getDir (SpecialKey KeyUp) = Just U
-    getDir (SpecialKey KeyDown) = Just D
-    getDir (SpecialKey KeyLeft) = Just L
-    getDir (SpecialKey KeyRight) = Just R
-    getDir _ = Nothing
 
 -- * Core game engine
 
@@ -65,29 +48,30 @@ tick = feedbackM (liftIO randomState) $ proc (dir, state) -> do
   newstate <- arrM (mapMaybeT (lift . lift . liftIO) . uncurry tickState) -< (dir, state)
   returnA -< (newstate, newstate)
 
-gameSF :: MonadIO m => MSF (MaybeT (DrawerT m)) () GameState
+gameSF :: MonadIO m => MSF (MaybeT (DrawerT m)) GameEvents GameState
-gameSF = proc () -> do
+gameSF = proc events -> do
   -- A "tick" is each frame that the snake advances
   n <- count -< ()
   let isTick = n `mod` 8 == 1
 
   -- Handle inputs (buffer)
-  dirs <- liftTransS handleEvents -< ()
+  dir <- fifoGate -< (events.directions, isTick)
-  dir <- fifoGate -< (dirs, isTick)
 
   -- only run `tick` whenever there's a tick
   pauseMSF undefined tick -< (dir, isTick)
 
-mainSF :: MonadIO m => MSF (DrawerT m) () ()
+mainSF :: MonadIO m => (Int, Int) -> MSF (DrawerT m) () ()
-mainSF = proc () -> do
+mainSF initSize = proc () -> do
-  keys <- getKeys -< ()
+  events <- handleEvents -< ()
-  let esc = SpecialKey KeyEsc `elem` keys
 
-  unpaused <- accumulateWith xor True -< esc
+  -- Handle window resize
-  state <- pauseMSF undefined (loopMaybe gameSF) -< ((), unpaused)
+  windowSize <- hold initSize -< events.windowResize
+
+  unpaused <- accumulateWith xor True -< events.pause
+  state <- pauseMSF undefined (loopMaybe gameSF) -< (events, unpaused)
 
   -- Display the current state
-  displayState -< state
+  displayState -< (state, windowSize)
   if unpaused
     then returnA -< ()
-    else displayPause -< ()
+    else displayPause -< windowSize

src/Game/State.hs

@@ -4,6 +4,9 @@ module Game.State where
 
 import System.Random
 import Control.Monad
+import Graphics.Gloss.Interface.IO.Game
+import Data.Maybe (mapMaybe)
+import Control.Applicative (asum)
 
 data Direction = U | D | L | R deriving (Eq)
 
@@ -23,6 +26,7 @@ setDir :: Direction -> Maybe Direction -> Direction
 setDir d Nothing = d
 setDir d (Just d') = if opposite d == d' then d else d'
 
+
 data GameState = GameState
   { snakePos :: [(Int, Int)],
     moveDir :: Direction,
@@ -47,3 +51,35 @@ randomState = do
   hd <- randomPos
   let snake = scanr movePos hd dirs
   GameState snake <$> randomDirection <*> randomPos
+
+
+data GameEvents = GameEvents
+  { directions :: [Direction],
+    pause :: Bool,
+    windowResize :: Maybe (Int, Int)
+  }
+
+parseEvents :: [Event] -> GameEvents
+parseEvents evs = GameEvents
+  (mapMaybe getDir evs) (any getPause evs) (asum $ fmap getResize evs)
+  where
+    getDir :: Event -> Maybe Direction
+    getDir (EventKey k Down _ _) = case k of
+      Char 'w' -> Just U
+      Char 's' -> Just D
+      Char 'a' -> Just L
+      Char 'd' -> Just R
+      SpecialKey KeyUp -> Just U
+      SpecialKey KeyDown -> Just D
+      SpecialKey KeyLeft -> Just L
+      SpecialKey KeyRight -> Just R
+      _ -> Nothing
+    getDir _ = Nothing
+
+    getPause :: Event -> Bool
+    getPause (EventKey (SpecialKey KeyEsc) Down _ _) = True
+    getPause _ = False
+
+    getResize :: Event -> Maybe (Int, Int)
+    getResize (EventResize resize) = Just resize
+    getResize _ = Nothing

src/Main.hs

@@ -4,6 +4,9 @@ import Data.MonadicStreamFunction
 import Game.Engine
 import Game.Utils
 import Graphics.Gloss
+import Graphics.Gloss.Interface.Environment (getScreenSize)
 
 main :: IO ()
-main = playMSF FullScreen black 60 (runDrawerS mainSF)
+main = do
+  size <- getScreenSize
+  playMSF FullScreen black 60 (runDrawerS $ mainSF size)