Compare commits

..

10 commits

Author SHA1 Message Date
Kiana Sheibani b885d70549
Switch to flake-parts based flake 2024-05-01 00:31:58 -04:00
Kiana Sheibani 65d257d4ad
Overhaul event handling 2024-04-23 00:10:41 -04:00
Kiana Sheibani 35e68719cb
Add display to pause screen 2024-04-22 22:41:39 -04:00
Kiana Sheibani a6a70e5dca
Add true randomness
Previously, randomness was faked via bad pseudo-randomness code, so
let's refactor some of this to add true randomness support.
2024-04-21 03:39:41 -04:00
Kiana Sheibani 7c61ddb24f
Update dependencies 2024-04-21 03:39:13 -04:00
Kiana Sheibani 59d344b678
Add pausing 2023-01-28 21:50:45 -05:00
Kiana Sheibani 0f54f532f0
Separate key-getting function from event handler 2023-01-28 16:07:41 -05:00
Kiana Sheibani 9da1dee6bc
Separate pure game logic from tick function 2023-01-28 16:07:19 -05:00
Kiana Sheibani c449d1e892
Write doc comments 2023-01-25 15:49:58 -05:00
Kiana Sheibani 079294e2df
Fix orientation error 2023-01-25 15:49:42 -05:00
8 changed files with 242 additions and 118 deletions

View file

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

View file

@ -1,52 +1,27 @@
{ {
description = "A snake game in Haskell using Dunai";
inputs = { inputs = {
nixpkgs.url = "github:NixOS/nixpkgs"; nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
flake-utils.url = "github:numtide/flake-utils"; 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, ... }: systems = nixpkgs.lib.systems.flakeExposed;
flake-utils.lib.eachDefaultSystem (system: perSystem = { config, system, self', pkgs, ... }: {
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 _module.args.pkgs = import nixpkgs {
pkgs.mesa_glu inherit system;
pkgs.freeglut config.allowBroken = true;
]);
};
in
{
# Used by `nix build` & `nix run` (prod exe)
packages.default = project false;
apps.default = {
type = "app";
program = "${self.packages.${system}.default}/bin/${execName}";
}; };
# Used by `nix develop` (dev shell) haskellProjects.default = {
devShell = project true; basePackages = pkgs.haskell.packages.ghc94;
}); };
packages.default = self'.packages.snake;
apps.default = self'.apps.snake;
};
};
} }

View file

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

View file

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

View file

@ -1,11 +1,15 @@
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
module Game.Engine where 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.Reader
import Control.Monad.Trans.MSF.Writer import Control.Monad.Trans.MSF.Writer
import Data.Bits (xor)
import Data.Functor (($>))
import Data.Maybe import Data.Maybe
import Data.MonadicStreamFunction import Data.MonadicStreamFunction
import Game.Display import Game.Display
@ -13,51 +17,61 @@ import Game.State
import Game.Utils import Game.Utils
import Graphics.Gloss import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game import Graphics.Gloss.Interface.IO.Game
import Control.Applicative (asum)
handleEvents :: Monad m => MSF (DrawerT m) () [Direction] -- * Input handling
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
tick :: Monad m => MSF (DrawerT m) (Maybe Direction) GameState handleEvents :: Monad m => MSF (DrawerT m) () GameEvents
tick = handleEvents = parseEvents <$> liftTransS (constM ask)
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
mainSF :: Monad m => MSF (DrawerT m) () () -- * Core game engine
mainSF = proc () -> do
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 -< () n <- count -< ()
let isTick = n `mod` 20 == 1 let isTick = n `mod` 8 == 1
-- handle inputs (buffer) -- Handle inputs (buffer)
dirs <- handleEvents -< () dir <- fifoGate -< (events.directions, isTick)
dir <- fifoGate -< (dirs, isTick)
state' <- -- only run `tick` whenever there's a tick
if isTick pauseMSF undefined tick -< (dir, isTick)
then fmap Just tick -< dir
else returnA -< Nothing mainSF :: MonadIO m => (Int, Int) -> MSF (DrawerT m) () ()
-- undefined is safe here because the first frame is guaranteed to be a tick mainSF initSize = proc () -> do
state <- hold undefined -< state' 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 -- Display the current state
displayState -< state displayState -< (state, windowSize)
if unpaused
then returnA -< ()
else displayPause -< windowSize

View file

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

View file

@ -1,5 +1,8 @@
{-# LANGUAGE Arrows #-}
module Game.Utils where module Game.Utils where
import Control.Monad.Trans.MSF.Maybe
import Control.Monad.Trans.MSF.Reader import Control.Monad.Trans.MSF.Reader
import Control.Monad.Trans.MSF.Writer import Control.Monad.Trans.MSF.Writer
import Data.IORef 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. -- | Display an MSF outputting a picture value as a window using Gloss.
-- Note that the MSF is not passed a real-time clock. -- 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 -> Int -> MSF IO [Event] Picture -> IO ()
playMSF display color freq msf = do playMSF display color freq msf = do
-- `react` doesn't allow inputs or outputs, so we have to use IORefs -- `react` doesn't allow inputs or outputs, so we have to use IORefs
@ -44,6 +52,12 @@ draw = arrM tell
-- * MSF convenience functions -- * 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 :: Monad m => a -> MSF m (Maybe a) a
hold = hold =
mealy mealy
@ -52,6 +66,8 @@ hold =
Just x' -> (x', x') 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 :: Monad m => MSF m ([a], Bool) (Maybe a)
fifoGate = fifoGate =
mealy mealy
@ -64,3 +80,14 @@ fifoGate =
where where
safeSnoc [] = (Nothing, []) safeSnoc [] = (Nothing, [])
safeSnoc (x : xs) = (Just x, xs) 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,6 +4,9 @@ import Data.MonadicStreamFunction
import Game.Engine import Game.Engine
import Game.Utils import Game.Utils
import Graphics.Gloss import Graphics.Gloss
import Graphics.Gloss.Interface.Environment (getScreenSize)
main :: IO () main :: IO ()
main = playMSF FullScreen black 60 (runDrawerS mainSF) main = do
size <- getScreenSize
playMSF FullScreen black 60 (runDrawerS $ mainSF size)