From 65d257d4ad60c7d4ca7aa29c32e53a18adef41c1 Mon Sep 17 00:00:00 2001 From: Kiana Sheibani Date: Tue, 23 Apr 2024 00:10:41 -0400 Subject: [PATCH] Overhaul event handling --- src/Game/Display.hs | 20 +++++++++---------- src/Game/Engine.hs | 48 +++++++++++++++------------------------------ src/Game/State.hs | 36 ++++++++++++++++++++++++++++++++++ src/Main.hs | 5 ++++- 4 files changed, 66 insertions(+), 43 deletions(-) diff --git a/src/Game/Display.hs b/src/Game/Display.hs index 03cf3d4..e5ebdcf 100644 --- a/src/Game/Display.hs +++ b/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 (toEnum -> x, toEnum -> y) = - translate (x * 25) (y * 25) $ rectangleSolid 25 25 +getSquare :: (Int, Int) -> (Int, Int) -> Picture +getSquare (toEnum -> winWidth, toEnum -> winHeight) (toEnum -> x, toEnum -> y) = + translate (x * winWidth / 30) (y * winHeight / 20) $ rectangleSolid (winWidth / 30) (winHeight / 20) -displayState :: Monad m => MSF (DrawerT m) GameState () -displayState = proc state -> do - draw -< pictures $ color green . getSquare <$> state.snakePos - draw -< color red $ getSquare state.berryPos +displayState :: Monad m => MSF (DrawerT m) (GameState, (Int, Int)) () +displayState = proc (state, windowSize) -> do + draw -< pictures $ color green . getSquare windowSize <$> state.snakePos + draw -< color red $ getSquare windowSize state.berryPos -displayPause :: Monad m => MSF (DrawerT m) () () -displayPause = proc () -> do - draw -< color (withAlpha 0.5 black) $ rectangleSolid 5000 5000 +displayPause :: Monad m => MSF (DrawerT m) (Int, Int) () +displayPause = proc (width, height) -> do + draw -< color (withAlpha 0.5 black) $ rectangleSolid (toEnum width) (toEnum height) draw -< color white $ scale 0.5 0.5 $ text "Paused" diff --git a/src/Game/Engine.hs b/src/Game/Engine.hs index df27b96..69f614d 100644 --- a/src/Game/Engine.hs +++ b/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] -getKeys = mapMaybe getKey <$> 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 +handleEvents :: Monad m => MSF (DrawerT m) () GameEvents +handleEvents = parseEvents <$> liftTransS (constM ask) -- * 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 = proc () -> do +gameSF :: MonadIO m => MSF (MaybeT (DrawerT m)) GameEvents GameState +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 -< (dirs, isTick) + dir <- fifoGate -< (events.directions, isTick) -- only run `tick` whenever there's a tick pauseMSF undefined tick -< (dir, isTick) -mainSF :: MonadIO m => MSF (DrawerT m) () () -mainSF = proc () -> do - keys <- getKeys -< () - let esc = SpecialKey KeyEsc `elem` keys +mainSF :: MonadIO m => (Int, Int) -> MSF (DrawerT m) () () +mainSF initSize = proc () -> do + events <- handleEvents -< () - unpaused <- accumulateWith xor True -< esc - state <- pauseMSF undefined (loopMaybe gameSF) -< ((), unpaused) + -- Handle window resize + 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 diff --git a/src/Game/State.hs b/src/Game/State.hs index f74c297..6778c44 100644 --- a/src/Game/State.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 33775f4..fd3f5a9 100644 --- a/src/Main.hs +++ b/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)