Overhaul event handling

This commit is contained in:
Kiana Sheibani 2024-04-23 00:10:41 -04:00
parent 35e68719cb
commit 65d257d4ad
Signed by: toki
GPG key ID: 6CB106C25E86A9F7
4 changed files with 66 additions and 43 deletions

View file

@ -14,16 +14,16 @@ import Game.Utils
import Graphics.Gloss import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game 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" draw -< color white $ scale 0.5 0.5 $ text "Paused"

View file

@ -17,29 +17,12 @@ import Game.State
import Game.Utils import Game.Utils
import Graphics.Gloss import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game import Graphics.Gloss.Interface.IO.Game
import Control.Applicative (asum)
-- * Input handling -- * 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 -- * 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) newstate <- arrM (mapMaybeT (lift . lift . liftIO) . uncurry tickState) -< (dir, state)
returnA -< (newstate, newstate) 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 -- A "tick" is each frame that the snake advances
n <- count -< () n <- count -< ()
let isTick = n `mod` 8 == 1 let isTick = n `mod` 8 == 1
-- Handle inputs (buffer) -- Handle inputs (buffer)
dirs <- liftTransS handleEvents -< () dir <- fifoGate -< (events.directions, isTick)
dir <- fifoGate -< (dirs, isTick)
-- only run `tick` whenever there's a tick -- only run `tick` whenever there's a tick
pauseMSF undefined tick -< (dir, isTick) 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 -- Display the current state
displayState -< state displayState -< (state, windowSize)
if unpaused if unpaused
then returnA -< () then returnA -< ()
else displayPause -< () else displayPause -< windowSize

View file

@ -4,6 +4,9 @@ module Game.State where
import System.Random import System.Random
import Control.Monad 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) data Direction = U | D | L | R deriving (Eq)
@ -23,6 +26,7 @@ setDir :: Direction -> Maybe Direction -> Direction
setDir d Nothing = d setDir d Nothing = d
setDir d (Just d') = if opposite d == d' then d else d' setDir d (Just d') = if opposite d == d' then d else d'
data GameState = GameState data GameState = GameState
{ snakePos :: [(Int, Int)], { snakePos :: [(Int, Int)],
moveDir :: Direction, moveDir :: Direction,
@ -47,3 +51,35 @@ randomState = do
hd <- randomPos hd <- randomPos
let snake = scanr movePos hd dirs let snake = scanr movePos hd dirs
GameState snake <$> randomDirection <*> randomPos 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

View file

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