Switch to flake-parts based flake

Previously, randomness was faked via bad pseudo-randomness code, so
let's refactor some of this to add true randomness support.

flake.lock

@@ -1,38 +1,76 @@
 {
   "nodes": {
-    "flake-utils": {
+    "flake-parts": {
+      "inputs": {
+        "nixpkgs-lib": "nixpkgs-lib"
+      },
       "locked": {
-        "lastModified": 1667395993,
-        "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
-        "owner": "numtide",
-        "repo": "flake-utils",
-        "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
+        "lastModified": 1712014858,
+        "narHash": "sha256-sB4SWl2lX95bExY2gMFG5HIzvva5AVMJd4Igm+GpZNw=",
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "rev": "9126214d0a59633752a136528f5f3b9aa8565b7d",
         "type": "github"
       },
       "original": {
-        "owner": "numtide",
-        "repo": "flake-utils",
+        "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",
         "type": "github"
       }
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1674004508,
-        "narHash": "sha256-sB5hYccS1Uoemc8pRA8z17HZ9hrGHrWqn8g0nQm7/lg=",
-        "owner": "NixOS",
+        "lastModified": 1714314149,
+        "narHash": "sha256-yNAevSKF4krRWacmLUsLK7D7PlfuY3zF0lYnGYNi9vQ=",
+        "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "c8b20e1c4168642f9fc92fb8d7fa465eb7a18c5c",
+        "rev": "cf8cc1201be8bc71b7cbbbdaf349b22f4f99c7ae",
         "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-utils": "flake-utils",
+        "flake-parts": "flake-parts",
+        "haskell-flake": "haskell-flake",
         "nixpkgs": "nixpkgs"
       }
     }

flake.nix

@@ -1,52 +1,27 @@
 {
-  description = "A snake game in Haskell using Dunai";
-
   inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs";
-    flake-utils.url = "github:numtide/flake-utils";
+    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;
         };
 
-  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}";
+        haskellProjects.default = {
+          basePackages = pkgs.haskell.packages.ghc94;
         };
 
-        # Used by `nix develop` (dev shell)
-        devShell = project true;
-      });
+        packages.default = self'.packages.snake;
+        apps.default = self'.apps.snake;
+      };
+    };
 }

snake.cabal

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

src/Game/Engine.hs

@@ -1,11 +1,15 @@
 {-# 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
@@ -13,51 +17,61 @@ import Game.State
 import Game.Utils
 import Graphics.Gloss
 import Graphics.Gloss.Interface.IO.Game
+import Control.Applicative (asum)
 
-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
+-- * Input handling
 
-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
+handleEvents :: Monad m => MSF (DrawerT m) () GameEvents
+handleEvents = parseEvents <$> liftTransS (constM ask)
 
-mainSF :: Monad m => MSF (DrawerT m) () ()
-mainSF = proc () -> do
+-- * 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
   n <- count -< ()
-  let isTick = n `mod` 20 == 1
+  let isTick = n `mod` 8 == 1
 
-  -- handle inputs (buffer)
-  dirs <- handleEvents -< ()
-  dir <- fifoGate -< (dirs, isTick)
+  -- Handle inputs (buffer)
+  dir <- fifoGate -< (events.directions, 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'
+  -- 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)
 
   -- Display the current state
-  displayState -< state
+  displayState -< (state, windowSize)
+  if unpaused
+    then returnA -< ()
+    else displayPause -< windowSize

src/Game/State.hs

@@ -1,23 +1,31 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Game.State where
 
-data Direction = U | D | L | R
+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)
 
 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 -> Bool
-opposite U D = True
-opposite D U = True
-opposite L R = True
-opposite R L = True
-opposite _ _ = False
+opposite :: Direction -> Direction
+opposite U = D
+opposite D = U
+opposite L = R
+opposite R = L
 
 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)],
@@ -25,5 +33,53 @@ data GameState = GameState
     berryPos :: (Int, Int)
   }
 
-initialState :: GameState
-initialState = GameState [(4, 4)] R (3, 3)
+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

src/Game/Utils.hs

@@ -1,5 +1,8 @@
+{-# 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
@@ -10,6 +13,11 @@ 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
@@ -44,6 +52,12 @@ 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
@@ -52,6 +66,8 @@ 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
@@ -64,3 +80,14 @@ 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,6 +4,9 @@ import Data.MonadicStreamFunction
 import Game.Engine
 import Game.Utils
 import Graphics.Gloss
+import Graphics.Gloss.Interface.Environment (getScreenSize)
 
 main :: IO ()
-main = playMSF FullScreen black 60 (runDrawerS mainSF)
+main = do
+  size <- getScreenSize
+  playMSF FullScreen black 60 (runDrawerS $ mainSF size)