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