Compare commits

..

No commits in common. "b885d70549f245b19887b6a31359fe6f32773532" and "ebb27755d283f24a06085f64590a15de2ce6158e" have entirely different histories.

8 changed files with 118 additions and 242 deletions

View file

@ -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"
}
}

View file

@ -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;
});
}

View file

@ -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

View file

@ -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

View file

@ -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

View file

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

View file

@ -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

View file

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