Write basic game structure

This commit is contained in:
Kiana Sheibani 2023-01-25 12:10:17 -05:00
parent 1c6b2bd4a1
commit e788ddee39
Signed by: toki
GPG key ID: 6CB106C25E86A9F7
4 changed files with 83 additions and 12 deletions

33
src/Game/Engine.hs Normal file
View file

@ -0,0 +1,33 @@
{-# LANGUAGE Arrows #-}
module Game.Engine where
import Data.MonadicStreamFunction
import Game.State
import Game.Utils
handleEvents :: Monad m => MSF (DrawerT m) () [Direction]
handleEvents = proc () -> do
returnA -< []
tick :: Monad m => MSF (DrawerT m) (Maybe Direction) GameState
tick = next initialState $ feedback initialState $ proc (dir, state) -> do
returnA -< (state, state)
mainSF :: Monad m => MSF (DrawerT m) () ()
mainSF = proc () -> do
n <- count -< ()
let isTick = n `mod` 20 == 1
-- handle inputs (buffer)
dirs <- handleEvents -< ()
dir <- fifoGate -< (dirs, isTick)
state' <-
if isTick
then fmap Just tick -< dir
else returnA -< Nothing
-- undefined is safe here because the first frame is guaranteed to be a tick
state <- hold undefined -< state'
returnA -< ()

19
src/Game/State.hs Normal file
View file

@ -0,0 +1,19 @@
module Game.State where
data Direction = U | D | L | R
deriving (Show, Eq)
movePos :: Direction -> (Int, Int) -> (Int, Int)
movePos U (x, y) = (x, y - 1)
movePos D (x, y) = (x, y + 1)
movePos L (x, y) = (x - 1, y)
movePos R (x, y) = (x + 1, y)
data GameState = GameState
{ snakePos :: [(Int, Int)],
moveDir :: Direction,
berryPos :: (Int, Int)
}
initialState :: GameState
initialState = GameState [(4, 4)] R (3, 3)

View file

@ -1,4 +1,4 @@
module Utils where module Game.Utils where
import Control.Monad.Trans.MSF.Reader import Control.Monad.Trans.MSF.Reader
import Control.Monad.Trans.MSF.Writer import Control.Monad.Trans.MSF.Writer
@ -24,19 +24,43 @@ playMSF display color freq msf = do
-- A function to handle input events. -- A function to handle input events.
handleInput e _ = do handleInput e _ = do
writeIORef evRef (Just e) writeIORef evRef (Just e)
react handle
-- A function to step the world one iteration. -- A function to step the world one iteration.
stepWorld _ _ = do stepWorld _ _ = do
writeIORef evRef Nothing
react handle react handle
writeIORef evRef Nothing
playIO display color freq () toPic handleInput stepWorld playIO display color freq () toPic handleInput stepWorld
type DrawerT m = WriterT Picture (ReaderT (Maybe Event) m) -- * DrawerT
type DrawerT m = WriterT Picture (Control.Monad.Trans.MSF.Reader.ReaderT (Maybe Event) m)
runDrawerS :: Monad m => MSF (DrawerT m) () () -> MSF m (Maybe Event) Picture runDrawerS :: Monad m => MSF (DrawerT m) () () -> MSF m (Maybe Event) Picture
runDrawerS msf = arr (,()) >>> runReaderS (runWriterS msf) >>> arr fst runDrawerS msf = arr (,()) >>> Control.Monad.Trans.MSF.Reader.runReaderS (runWriterS msf) >>> arr fst
draw :: Monad m => MSF (DrawerT m) Picture () draw :: Monad m => MSF (DrawerT m) Picture ()
draw = arrM tell draw = arrM tell
-- * MSF convenience functions
hold :: Monad m => a -> MSF m (Maybe a) a
hold =
mealy
( \x y -> case x of
Nothing -> (y, y)
Just x' -> (x', x')
)
fifoGate :: Monad m => MSF m ([a], Bool) (Maybe a)
fifoGate =
mealy
( \(xs, b) ys ->
if b
then safeSnoc (ys ++ xs)
else (Nothing, ys ++ xs)
)
[]
where
safeSnoc [] = (Nothing, [])
safeSnoc (x : xs) = (Just x, xs)

View file

@ -1,14 +1,9 @@
{-# LANGUAGE Arrows #-}
module Main where module Main where
import Data.MonadicStreamFunction import Data.MonadicStreamFunction
import Game.Engine
import Game.Utils
import Graphics.Gloss import Graphics.Gloss
import Utils
mainSF :: MSF (DrawerT IO) () ()
mainSF = proc () -> do
draw -< color white $ circleSolid 40
main :: IO () main :: IO ()
main = playMSF FullScreen black 60 (runDrawerS mainSF) main = playMSF FullScreen black 60 (runDrawerS mainSF)