diff --git a/flake.lock b/flake.lock index 9333a82..7f0b48f 100644 --- a/flake.lock +++ b/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" } } diff --git a/flake.nix b/flake.nix index c2568c0..50b4996 100644 --- a/flake.nix +++ b/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 ]; - 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 + systems = nixpkgs.lib.systems.flakeExposed; + perSystem = { config, system, self', pkgs, ... }: { - 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}"; + _module.args.pkgs = import nixpkgs { + inherit system; + config.allowBroken = true; }; - # Used by `nix develop` (dev shell) - devShell = project true; - }); + haskellProjects.default = { + basePackages = pkgs.haskell.packages.ghc94; + }; + + packages.default = self'.packages.snake; + apps.default = self'.apps.snake; + }; + }; } diff --git a/snake.cabal b/snake.cabal index a9edfcc..ec96f03 100644 --- a/snake.cabal +++ b/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 diff --git a/src/Game/Display.hs b/src/Game/Display.hs index 99d3be7..e5ebdcf 100644 --- a/src/Game/Display.hs +++ b/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" diff --git a/src/Game/Engine.hs b/src/Game/Engine.hs index 67d4807..69f614d 100644 --- a/src/Game/Engine.hs +++ b/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 diff --git a/src/Game/State.hs b/src/Game/State.hs index 0dd6f38..6778c44 100644 --- a/src/Game/State.hs +++ b/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 diff --git a/src/Game/Utils.hs b/src/Game/Utils.hs index 443e29a..2e12fe2 100644 --- a/src/Game/Utils.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 33775f4..fd3f5a9 100644 --- a/src/Main.hs +++ b/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)