Write basic game structure

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 -< ()

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)

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)

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)