flake.lock

@@ -1,76 +1,38 @@
 {
   "nodes": {
-    "flake-parts": {
-      "inputs": {
-        "nixpkgs-lib": "nixpkgs-lib"
-      },
+    "flake-utils": {
       "locked": {
-        "lastModified": 1712014858,
-        "narHash": "sha256-sB4SWl2lX95bExY2gMFG5HIzvva5AVMJd4Igm+GpZNw=",
-        "owner": "hercules-ci",
-        "repo": "flake-parts",
-        "rev": "9126214d0a59633752a136528f5f3b9aa8565b7d",
+        "lastModified": 1667395993,
+        "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
         "type": "github"
       },
       "original": {
-        "owner": "hercules-ci",
-        "repo": "flake-parts",
-        "type": "github"
-      }
-    },
-    "haskell-flake": {
-      "locked": {
-        "lastModified": 1714268160,
-        "narHash": "sha256-LNbwGgBT5EqfWN7pqYbj71VLLGQJqWkde3ToOhkM5vM=",
-        "owner": "srid",
-        "repo": "haskell-flake",
-        "rev": "5b0857e0b7feec60bf00e075f7859746d52b8564",
-        "type": "github"
-      },
-      "original": {
-        "owner": "srid",
-        "repo": "haskell-flake",
+        "owner": "numtide",
+        "repo": "flake-utils",
         "type": "github"
       }
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1714314149,
-        "narHash": "sha256-yNAevSKF4krRWacmLUsLK7D7PlfuY3zF0lYnGYNi9vQ=",
-        "owner": "nixos",
+        "lastModified": 1674004508,
+        "narHash": "sha256-sB5hYccS1Uoemc8pRA8z17HZ9hrGHrWqn8g0nQm7/lg=",
+        "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "cf8cc1201be8bc71b7cbbbdaf349b22f4f99c7ae",
+        "rev": "c8b20e1c4168642f9fc92fb8d7fa465eb7a18c5c",
         "type": "github"
       },
       "original": {
-        "owner": "nixos",
-        "ref": "nixpkgs-unstable",
-        "repo": "nixpkgs",
-        "type": "github"
-      }
-    },
-    "nixpkgs-lib": {
-      "locked": {
-        "dir": "lib",
-        "lastModified": 1711703276,
-        "narHash": "sha256-iMUFArF0WCatKK6RzfUJknjem0H9m4KgorO/p3Dopkk=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "d8fe5e6c92d0d190646fb9f1056741a229980089",
-        "type": "github"
-      },
-      "original": {
-        "dir": "lib",
-        "owner": "NixOS",
-        "ref": "nixos-unstable",
-        "repo": "nixpkgs",
         "type": "github"
       }
     },
     "root": {
       "inputs": {
-        "flake-parts": "flake-parts",
-        "haskell-flake": "haskell-flake",
+        "flake-utils": "flake-utils",
         "nixpkgs": "nixpkgs"
       }
     }

flake.nix

@@ -1,27 +1,52 @@
 {
+  description = "A snake game in Haskell using Dunai";
+
   inputs = {
-    nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
-    flake-parts.url = "github:hercules-ci/flake-parts";
-    haskell-flake.url = "github:srid/haskell-flake";
-  };
-  outputs = inputs@{ self, nixpkgs, flake-parts, ... }:
-    flake-parts.lib.mkFlake { inherit inputs; } {
-      imports = [ inputs.haskell-flake.flakeModule ];
-
-      systems = nixpkgs.lib.systems.flakeExposed;
-      perSystem = { config, system, self', pkgs, ... }: {
-
-        _module.args.pkgs = import nixpkgs {
-          inherit system;
-          config.allowBroken = true;
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
   };
 
-        haskellProjects.default = {
-          basePackages = pkgs.haskell.packages.ghc94;
+  outputs = { self, nixpkgs, flake-utils, ... }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs = nixpkgs.legacyPackages.${system};
+        
+        # package/executable name
+        packageName = "snake";
+        execName = packageName;
+        
+        # version of ghc used
+        hp = pkgs.haskell.packages.ghc92;
+        
+        project = returnShellEnv:
+          hp.developPackage {
+            inherit returnShellEnv;
+            name = packageName;
+            root = ./.;
+            withHoogle = false;
+            modifier = drv:
+              pkgs.haskell.lib.addBuildTools drv (with hp; [
+                # Specify your build/dev dependencies here.
+                hlint
+                haskell-language-server
+                ormolu
+
+                pkgs.mesa
+                pkgs.mesa_glu
+                pkgs.freeglut
+              ]);
+          };
+      in
+      {
+        # Used by `nix build` & `nix run` (prod exe)
+        packages.default = project false;
+
+        apps.default = {
+          type = "app";
+          program = "${self.packages.${system}.default}/bin/${execName}";
         };
 
-        packages.default = self'.packages.snake;
-        apps.default = self'.apps.snake;
-      };
-    };
+        # Used by `nix develop` (dev shell)
+        devShell = project true;
+      });
 }

snake.cabal

@@ -9,14 +9,8 @@ build-type:    Simple
 executable snake
   hs-source-dirs: src
   main-is:        Main.hs
-  other-modules:  Game.Display,
-                  Game.Engine,
-                  Game.State,
-                  Game.Utils
   default-language:   GHC2021
   default-extensions: Arrows
   build-depends: base,
-                 mtl,
-                 random,
                  dunai,
                  gloss

src/Game/Display.hs

@@ -14,16 +14,11 @@ import Game.Utils
 import Graphics.Gloss
 import Graphics.Gloss.Interface.IO.Game
 
-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)
+getSquare :: (Int, Int) -> Picture
+getSquare (toEnum -> x, toEnum -> y) =
+  translate (x * 25) (y * 25) $ rectangleSolid 25 25
 
-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) (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"
+displayState :: Monad m => MSF (DrawerT m) GameState ()
+displayState = proc state -> do
+  draw -< mconcat $ color green . getSquare <$> state.snakePos
+  draw -< color red $ getSquare state.berryPos

src/Game/Engine.hs

@@ -1,15 +1,11 @@
 {-# LANGUAGE Arrows #-}
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Game.Engine where
 
-import Control.Monad (guard)
-import Control.Monad.Trans
-import Control.Monad.Trans.MSF.Maybe
 import Control.Monad.Trans.MSF.Reader
 import Control.Monad.Trans.MSF.Writer
-import Data.Bits (xor)
-import Data.Functor (($>))
 import Data.Maybe
 import Data.MonadicStreamFunction
 import Game.Display
@@ -17,61 +13,51 @@ import Game.State
 import Game.Utils
 import Graphics.Gloss
 import Graphics.Gloss.Interface.IO.Game
-import Control.Applicative (asum)
 
--- * Input handling
+handleEvents :: Monad m => MSF (DrawerT m) () [Direction]
+handleEvents = mapMaybe getDir <$> liftTransS (constM ask)
+  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
 
-handleEvents :: Monad m => MSF (DrawerT m) () GameEvents
-handleEvents = parseEvents <$> liftTransS (constM ask)
+tick :: Monad m => MSF (DrawerT m) (Maybe Direction) GameState
+tick =
+  next initialState $
+    mealy
+      ( \input state ->
+          let moveDir = setDir state.moveDir input
+              snakePos = movePos moveDir <$> state.snakePos
+              berryPos = state.berryPos
+              newstate = GameState {..}
+           in (newstate, newstate)
+      )
+      initialState
 
--- * Core game engine
-
-tickState :: Maybe Direction -> GameState -> MaybeT IO GameState
-tickState dir state =
-  let moveDir = setDir state.moveDir dir
-      newBlock = movePos moveDir $ head state.snakePos
-      hitBerry = newBlock == state.berryPos
-      snakePos =
-        newBlock
-          : if hitBerry
-            then state.snakePos
-            else init state.snakePos
-      isHit = head snakePos `notElem` tail snakePos
-      berryPos =
-        if hitBerry
-          then randomPos
-          else pure state.berryPos
-   in MaybeT $ (guard isHit $>) <$> (GameState snakePos moveDir <$> berryPos)
-
-tick :: MonadIO m => MSF (MaybeT (DrawerT m)) (Maybe Direction) GameState
-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)) GameEvents GameState
-gameSF = proc events -> do
-  -- A "tick" is each frame that the snake advances
+mainSF :: Monad m => MSF (DrawerT m) () ()
+mainSF = proc () -> do
   n <- count -< ()
-  let isTick = n `mod` 8 == 1
+  let isTick = n `mod` 20 == 1
 
-  -- Handle inputs (buffer)
-  dir <- fifoGate -< (events.directions, isTick)
+  -- handle inputs (buffer)
+  dirs <- handleEvents -< ()
+  dir <- fifoGate -< (dirs, isTick)
 
-  -- only run `tick` whenever there's a tick
-  pauseMSF undefined tick -< (dir, isTick)
-
-mainSF :: MonadIO m => (Int, Int) -> MSF (DrawerT m) () ()
-mainSF initSize = proc () -> do
-  events <- handleEvents -< ()
-
-  -- Handle window resize
-  windowSize <- hold initSize -< events.windowResize
-
-  unpaused <- accumulateWith xor True -< events.pause
-  state <- pauseMSF undefined (loopMaybe gameSF) -< (events, unpaused)
+  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'
 
   -- Display the current state
-  displayState -< (state, windowSize)
-  if unpaused
-    then returnA -< ()
-    else displayPause -< windowSize
+  displayState -< state

src/Game/State.hs

@@ -1,31 +1,23 @@
-{-# LANGUAGE LambdaCase #-}
-
 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)
+data Direction = U | D | L | R
 
 movePos :: Direction -> (Int, Int) -> (Int, Int)
-movePos U (x, y) = (x, y + 1)
-movePos D (x, y) = (x, y - 1)
+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)
 
-opposite :: Direction -> Direction
-opposite U = D
-opposite D = U
-opposite L = R
-opposite R = L
+opposite :: Direction -> Direction -> Bool
+opposite U D = True
+opposite D U = True
+opposite L R = True
+opposite R L = True
+opposite _ _ = False
 
 setDir :: Direction -> Maybe Direction -> Direction
 setDir d Nothing = d
-setDir d (Just d') = if opposite d == d' then d else d'
-
+setDir d (Just d') = if opposite d d' then d else d'
 
 data GameState = GameState
   { snakePos :: [(Int, Int)],
@@ -33,53 +25,5 @@ data GameState = GameState
     berryPos :: (Int, Int)
   }
 
-initialLength :: Int
-initialLength = 3
-
-randomPos :: IO (Int, Int)
-randomPos = (,) <$> randomRIO (-10, 10) <*> randomRIO (-10, 10)
-
-randomState :: IO GameState
-randomState = do
-  let randomDirection =
-        (\case
-          1 -> U
-          2 -> D
-          3 -> L
-          4 -> R) <$> randomRIO @Int (1,4)
-  dirs <- replicateM (initialLength - 1) randomDirection
-  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
+initialState :: GameState
+initialState = GameState [(4, 4)] R (3, 3)

src/Game/Utils.hs

@@ -1,8 +1,5 @@
-{-# LANGUAGE Arrows #-}
-
 module Game.Utils where
 
-import Control.Monad.Trans.MSF.Maybe
 import Control.Monad.Trans.MSF.Reader
 import Control.Monad.Trans.MSF.Writer
 import Data.IORef
@@ -13,11 +10,6 @@ import Graphics.Gloss.Interface.IO.Game
 
 -- | Display an MSF outputting a picture value as a window using Gloss.
 -- Note that the MSF is not passed a real-time clock.
---
--- The MSF is always called at a consistent framerate, regardless of when input
--- events are registered. It is passed a buffered list of all events that
--- occured between the last and current frames, with the first event in the
--- list being the latest.
 playMSF :: Display -> Color -> Int -> MSF IO [Event] Picture -> IO ()
 playMSF display color freq msf = do
   -- `react` doesn't allow inputs or outputs, so we have to use IORefs
@@ -52,12 +44,6 @@ draw = arrM tell
 
 -- * MSF convenience functions
 
-feedbackM :: Monad m => m c -> MSF m (a, c) (b, c) -> MSF m a b
-feedbackM init msf = feedback Nothing $ proc (x, state) -> do
-  state' <- arrM (maybe init pure) -< state
-  (y, newstate) <- msf -< (x, state')
-  returnA -< (y, Just newstate)
-
 hold :: Monad m => a -> MSF m (Maybe a) a
 hold =
   mealy
@@ -66,8 +52,6 @@ hold =
         Just x' -> (x', x')
     )
 
--- | Buffers and returns the elements in FIFO order, only allowing elements to
--- shift out whenever the input boolean is true.
 fifoGate :: Monad m => MSF m ([a], Bool) (Maybe a)
 fifoGate =
   mealy
@@ -80,14 +64,3 @@ fifoGate =
   where
     safeSnoc [] = (Nothing, [])
     safeSnoc (x : xs) = (Just x, xs)
-
-loopMaybe :: Monad m => MSF (MaybeT m) a b -> MSF m a b
-loopMaybe msf = msf `catchMaybe` loopMaybe msf
-
-pauseMSF :: Monad m => b -> MSF m a b -> MSF m (a, Bool) b
-pauseMSF def msf = proc (x, b) -> do
-  y <-
-    if b
-      then fmap Just msf -< x
-      else returnA -< Nothing
-  hold def -< y

src/Main.hs

@@ -4,9 +4,6 @@ import Data.MonadicStreamFunction
 import Game.Engine
 import Game.Utils
 import Graphics.Gloss
-import Graphics.Gloss.Interface.Environment (getScreenSize)
 
 main :: IO ()
-main = do
-  size <- getScreenSize
-  playMSF FullScreen black 60 (runDrawerS $ mainSF size)
+main = playMSF FullScreen black 60 (runDrawerS mainSF)