diff --git a/src/Game/Engine.hs b/src/Game/Engine.hs new file mode 100644 index 0000000..8181d96 --- /dev/null +++ b/src/Game/Engine.hs @@ -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 -< () diff --git a/src/Game/State.hs b/src/Game/State.hs new file mode 100644 index 0000000..d8dcc82 --- /dev/null +++ b/src/Game/State.hs @@ -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) diff --git a/src/Utils.hs b/src/Game/Utils.hs similarity index 64% rename from src/Utils.hs rename to src/Game/Utils.hs index 10a1047..ba267b2 100644 --- a/src/Utils.hs +++ b/src/Game/Utils.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs index f901016..33775f4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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)