Write basic game structure
This commit is contained in:
parent
1c6b2bd4a1
commit
e788ddee39
33
src/Game/Engine.hs
Normal file
33
src/Game/Engine.hs
Normal 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
19
src/Game/State.hs
Normal 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)
|
|
@ -1,4 +1,4 @@
|
|||
module Utils where
|
||||
module Game.Utils where
|
||||
|
||||
import Control.Monad.Trans.MSF.Reader
|
||||
import Control.Monad.Trans.MSF.Writer
|
||||
|
@ -24,19 +24,43 @@ playMSF display color freq msf = do
|
|||
-- A function to handle input events.
|
||||
handleInput e _ = do
|
||||
writeIORef evRef (Just e)
|
||||
react handle
|
||||
|
||||
-- A function to step the world one iteration.
|
||||
stepWorld _ _ = do
|
||||
writeIORef evRef Nothing
|
||||
react handle
|
||||
writeIORef evRef Nothing
|
||||
|
||||
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 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 = 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)
|
|
@ -1,14 +1,9 @@
|
|||
{-# LANGUAGE Arrows #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Data.MonadicStreamFunction
|
||||
import Game.Engine
|
||||
import Game.Utils
|
||||
import Graphics.Gloss
|
||||
import Utils
|
||||
|
||||
mainSF :: MSF (DrawerT IO) () ()
|
||||
mainSF = proc () -> do
|
||||
draw -< color white $ circleSolid 40
|
||||
|
||||
main :: IO ()
|
||||
main = playMSF FullScreen black 60 (runDrawerS mainSF)
|
||||
|
|
Loading…
Reference in a new issue