Overhaul event handling
This commit is contained in:
parent
35e68719cb
commit
65d257d4ad
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue