mirror of
https://git.sr.ht/~magic_rb/haskell-games
synced 2024-11-21 15:24:22 +01:00
Snake in Haskell
This commit is contained in:
commit
1849375d7d
3
.gitignore
vendored
Normal file
3
.gitignore
vendored
Normal file
|
@ -0,0 +1,3 @@
|
||||||
|
.direnv
|
||||||
|
result*
|
||||||
|
.stack-work
|
27
flake.lock
Normal file
27
flake.lock
Normal file
|
@ -0,0 +1,27 @@
|
||||||
|
{
|
||||||
|
"nodes": {
|
||||||
|
"nixpkgs": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1695145219,
|
||||||
|
"narHash": "sha256-Eoe9IHbvmo5wEDeJXKFOpKUwxYJIOxKUesounVccNYk=",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"rev": "5ba549eafcf3e33405e5f66decd1a72356632b96",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "NixOS",
|
||||||
|
"ref": "nixos-unstable",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": {
|
||||||
|
"inputs": {
|
||||||
|
"nixpkgs": "nixpkgs"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": "root",
|
||||||
|
"version": 7
|
||||||
|
}
|
53
flake.nix
Normal file
53
flake.nix
Normal file
|
@ -0,0 +1,53 @@
|
||||||
|
{
|
||||||
|
inputs.nixpkgs.url = "github:NixOS/nixpkgs?ref=nixos-unstable";
|
||||||
|
|
||||||
|
outputs = { self, nixpkgs, ... }@inputs:
|
||||||
|
let
|
||||||
|
supportedSystems = [ "x86_64-linux" ];
|
||||||
|
forAllSystems' = nixpkgs.lib.genAttrs;
|
||||||
|
forAllSystems = forAllSystems' supportedSystems;
|
||||||
|
|
||||||
|
pkgsForSystem =
|
||||||
|
system:
|
||||||
|
import nixpkgs { inherit system; overlays = [ ]; };
|
||||||
|
in
|
||||||
|
{
|
||||||
|
devShells = forAllSystems (system:
|
||||||
|
let
|
||||||
|
pkgs = pkgsForSystem system;
|
||||||
|
hPkgs = pkgs.haskell.packages."ghc962";
|
||||||
|
stack-wrapper = pkgs.symlinkJoin {
|
||||||
|
name = "stack";
|
||||||
|
paths = [ pkgs.stack ];
|
||||||
|
buildInputs = [ pkgs.makeWrapper ];
|
||||||
|
postBuild = ''
|
||||||
|
wrapProgram $out/bin/stack \
|
||||||
|
--add-flags "\
|
||||||
|
--no-nix \
|
||||||
|
--system-ghc \
|
||||||
|
--no-install-ghc \
|
||||||
|
"
|
||||||
|
'';
|
||||||
|
};
|
||||||
|
in
|
||||||
|
{
|
||||||
|
default =
|
||||||
|
pkgs.mkShell rec {
|
||||||
|
LD_LIBRARY_PATH = pkgs.lib.makeLibraryPath buildInputs;
|
||||||
|
buildInputs = with pkgs; [
|
||||||
|
stdenv.cc
|
||||||
|
stack-wrapper
|
||||||
|
hPkgs.ghc
|
||||||
|
hPkgs.implicit-hie
|
||||||
|
hPkgs.haskell-language-server
|
||||||
|
SDL2
|
||||||
|
SDL2_image
|
||||||
|
libtiff
|
||||||
|
libwebp
|
||||||
|
pkg-config
|
||||||
|
];
|
||||||
|
};
|
||||||
|
}
|
||||||
|
);
|
||||||
|
};
|
||||||
|
}
|
7
hie.yaml
Normal file
7
hie.yaml
Normal file
|
@ -0,0 +1,7 @@
|
||||||
|
cradle:
|
||||||
|
stack:
|
||||||
|
- path: "snake/lib"
|
||||||
|
component: "snake:lib"
|
||||||
|
|
||||||
|
- path: "snake/app/Main.hs"
|
||||||
|
component: "snake:exe:snake"
|
405
snake/app/Main.hs
Normal file
405
snake/app/Main.hs
Normal file
|
@ -0,0 +1,405 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE BlockArguments #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Data.Text qualified as T
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Snake
|
||||||
|
import SDL.Video qualified as SDL
|
||||||
|
import SDL.Video.Renderer qualified as SDL
|
||||||
|
import SDL.Input.Keyboard qualified as SDL
|
||||||
|
import SDL.Init qualified as SDL
|
||||||
|
import SDL.Vect qualified as SDL
|
||||||
|
import SDL.Event qualified as SDL
|
||||||
|
import Control.Exception
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.Extra (whileM, whenM)
|
||||||
|
import Data.IORef
|
||||||
|
import Effectful
|
||||||
|
import Effectful.State.Static.Local
|
||||||
|
import SDL (($=))
|
||||||
|
import SDL.Image qualified as SDLI
|
||||||
|
import Control.Lens hiding ((.=), (%=))
|
||||||
|
import Foreign.C
|
||||||
|
import Effectful.Reader.Static
|
||||||
|
import Data.Vector.Storable qualified as SV
|
||||||
|
import System.Random
|
||||||
|
|
||||||
|
data Point = Point Int Int
|
||||||
|
deriving (Show, Eq)
|
||||||
|
data Square = Square Point Point
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
scalePoint :: Int -> Point -> Point
|
||||||
|
scalePoint scale (Point x y) = Point (x * scale) (y * scale)
|
||||||
|
|
||||||
|
addPoint :: Point -> Point -> Point
|
||||||
|
addPoint (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)
|
||||||
|
|
||||||
|
directionOpposite :: Direction -> Direction
|
||||||
|
directionOpposite direction = case direction of
|
||||||
|
East -> West
|
||||||
|
West -> East
|
||||||
|
North -> South
|
||||||
|
South -> North
|
||||||
|
|
||||||
|
directionToPoint :: Direction -> Point
|
||||||
|
directionToPoint direction =
|
||||||
|
case direction of
|
||||||
|
East -> Point 1 0
|
||||||
|
West -> Point (-1) 0
|
||||||
|
North -> Point 0 (-1)
|
||||||
|
South -> Point 0 1
|
||||||
|
|
||||||
|
clampPoint :: (Int, Int) -> Point -> Point
|
||||||
|
clampPoint (width, height) (Point x y) = Point x' y'
|
||||||
|
where
|
||||||
|
x' = clamp x width
|
||||||
|
y' = clamp y height
|
||||||
|
clamp coord size =
|
||||||
|
case coord of
|
||||||
|
coord | coord < 0 -> size + coord
|
||||||
|
coord -> coord `rem` size
|
||||||
|
|
||||||
|
pointToSquare :: Int -> Point -> Square
|
||||||
|
pointToSquare scale point@(Point x y) = Square (scalePoint scale point) (Point scale scale)
|
||||||
|
|
||||||
|
pointToV2 :: Integral i => Point -> SDL.V2 i
|
||||||
|
pointToV2 (Point x y) = SDL.V2 (fromIntegral x) (fromIntegral y)
|
||||||
|
|
||||||
|
squareToRectangle :: Integral i => Square -> SDL.Rectangle i
|
||||||
|
squareToRectangle (Square (Point x y) (Point width height)) = SDL.Rectangle (SDL.P (SDL.V2 (fromIntegral x) (fromIntegral y))) (SDL.V2 (fromIntegral width) (fromIntegral height))
|
||||||
|
|
||||||
|
data Direction
|
||||||
|
= East
|
||||||
|
| West
|
||||||
|
| North
|
||||||
|
| South
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data Snake
|
||||||
|
= Snake
|
||||||
|
{ head :: Point
|
||||||
|
, body :: [Point]
|
||||||
|
, direction :: Direction
|
||||||
|
, growth :: Int
|
||||||
|
}
|
||||||
|
deriving Show
|
||||||
|
makeLensesFor
|
||||||
|
[ ("head", "head")
|
||||||
|
, ("body", "body")
|
||||||
|
, ("growth", "growth")
|
||||||
|
, ("direction", "direction")
|
||||||
|
] ''Snake
|
||||||
|
|
||||||
|
data WorldState
|
||||||
|
= WorldState
|
||||||
|
{ snake :: Snake
|
||||||
|
, apple :: Maybe Point
|
||||||
|
, gameOver :: Bool
|
||||||
|
}
|
||||||
|
deriving Show
|
||||||
|
makeLensesFor
|
||||||
|
[ ("snake", "snake")
|
||||||
|
, ("apple", "apple")
|
||||||
|
, ("gameOver", "gameOver")
|
||||||
|
] ''WorldState
|
||||||
|
|
||||||
|
data GameState
|
||||||
|
= GameState
|
||||||
|
{ run :: Bool
|
||||||
|
, pastWorldStates :: [WorldState]
|
||||||
|
, worldState :: WorldState
|
||||||
|
, frameNumber :: Int
|
||||||
|
, reverseTime :: Bool
|
||||||
|
}
|
||||||
|
deriving Show
|
||||||
|
makeLensesFor
|
||||||
|
[ ("run", "run")
|
||||||
|
, ("pastWorldStates", "pastWorldStates")
|
||||||
|
, ("frameNumber", "frameNumber")
|
||||||
|
, ("worldState", "worldState")
|
||||||
|
, ("reverseTime", "reverseTime")
|
||||||
|
] ''GameState
|
||||||
|
|
||||||
|
initialWorldState :: WorldState
|
||||||
|
initialWorldState
|
||||||
|
= WorldState
|
||||||
|
{ snake
|
||||||
|
= Snake
|
||||||
|
{ head = Point 2 0
|
||||||
|
, body = [ Point 1 0, Point 0 0 ]
|
||||||
|
, growth = 0
|
||||||
|
, direction = East
|
||||||
|
}
|
||||||
|
, apple = Nothing
|
||||||
|
, gameOver = False
|
||||||
|
}
|
||||||
|
|
||||||
|
initialGameState :: GameState
|
||||||
|
initialGameState
|
||||||
|
= GameState
|
||||||
|
{ run = True
|
||||||
|
, pastWorldStates = []
|
||||||
|
, worldState = initialWorldState
|
||||||
|
, frameNumber = 0
|
||||||
|
, reverseTime = False
|
||||||
|
}
|
||||||
|
|
||||||
|
data GameConfig
|
||||||
|
= GameConfig
|
||||||
|
{ gridDimensions :: (Int, Int)
|
||||||
|
, updatesPerSecond :: Int
|
||||||
|
}
|
||||||
|
deriving Show
|
||||||
|
makeLensesFor
|
||||||
|
[ ("gridDimensions", "gridDimensions")
|
||||||
|
, ("updatesPerSecond", "updatesPerSecond")
|
||||||
|
] ''GameConfig
|
||||||
|
|
||||||
|
(.=) :: State s :> es => ASetter s s a b -> b -> Eff es ()
|
||||||
|
l .= b = modify (l .~ b)
|
||||||
|
{-# INLINE (.=) #-}
|
||||||
|
|
||||||
|
(%=) :: State s :> es => ASetter s s a b -> (a -> b) -> Eff es ()
|
||||||
|
l %= f = modify (l %~ f)
|
||||||
|
{-# INLINE (%=) #-}
|
||||||
|
|
||||||
|
(%.=) :: State s :> es => Lens s s a b -> (s -> b) -> Eff es ()
|
||||||
|
l %.= f = modify (\s -> l %~ const (f s) $ s)
|
||||||
|
{-# INLINE (%.=) #-}
|
||||||
|
|
||||||
|
renderHead
|
||||||
|
:: Snake
|
||||||
|
-> Eff es (Point, SDL.Rectangle CInt)
|
||||||
|
renderHead snake = do
|
||||||
|
let scale = 20
|
||||||
|
let texture = case snake.direction of
|
||||||
|
East -> Point 0 0
|
||||||
|
West -> Point 1 1
|
||||||
|
South -> Point 0 2
|
||||||
|
North -> Point 1 2
|
||||||
|
|
||||||
|
pure $ ((texture,) . squareToRectangle . pointToSquare scale) snake.head
|
||||||
|
|
||||||
|
renderSnake
|
||||||
|
:: (Reader GameConfig :> es)
|
||||||
|
=> Snake
|
||||||
|
-> Eff es [(Point, SDL.Rectangle CInt)]
|
||||||
|
renderSnake snake = do
|
||||||
|
let scale = 20
|
||||||
|
pure $ map ((Point 1 0,) . squareToRectangle . pointToSquare scale) snake.body
|
||||||
|
|
||||||
|
renderApple
|
||||||
|
:: ()
|
||||||
|
=> Point
|
||||||
|
-> Eff es (Point, SDL.Rectangle CInt)
|
||||||
|
renderApple apple = do
|
||||||
|
let scale = 20
|
||||||
|
pure $ ((Point 0 1,) . squareToRectangle . pointToSquare scale) apple
|
||||||
|
|
||||||
|
moveSnake
|
||||||
|
:: (Reader GameConfig :> es, State Snake :> es)
|
||||||
|
=> Direction
|
||||||
|
-> Eff es ()
|
||||||
|
moveSnake direction = do
|
||||||
|
dims <- asks @GameConfig (\s -> s.gridDimensions)
|
||||||
|
newLength <- gets @Snake \snake ->
|
||||||
|
if snake.growth > 0 then
|
||||||
|
length snake.body
|
||||||
|
else
|
||||||
|
length snake.body - 1
|
||||||
|
|
||||||
|
body %.= \snake -> snake.head : take newLength snake.body
|
||||||
|
Main.head %= (clampPoint dims . addPoint (directionToPoint direction))
|
||||||
|
growth %= \growth ->
|
||||||
|
if growth > 0 then
|
||||||
|
growth - 1
|
||||||
|
else
|
||||||
|
growth
|
||||||
|
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
changeDirection
|
||||||
|
:: (State GameState :> es)
|
||||||
|
=> Direction
|
||||||
|
-> Eff es ()
|
||||||
|
changeDirection dir = do
|
||||||
|
lastDirection <- gets @GameState (\s -> (Prelude.head s.pastWorldStates).snake.direction)
|
||||||
|
when (dir /= directionOpposite lastDirection) $ (worldState . snake . direction) .= dir
|
||||||
|
|
||||||
|
setReversed
|
||||||
|
:: (State GameState :> es)
|
||||||
|
=> Bool
|
||||||
|
-> Eff es ()
|
||||||
|
setReversed r = do
|
||||||
|
reverseTime .= r
|
||||||
|
|
||||||
|
promoteWorldState
|
||||||
|
:: (State GameState :> es)
|
||||||
|
=> Eff es ()
|
||||||
|
promoteWorldState =
|
||||||
|
pastWorldStates %.= (\state -> state.worldState : state.pastWorldStates)
|
||||||
|
|
||||||
|
eatApple
|
||||||
|
:: (State GameState :> es, Reader GameConfig :> es, State StdGen :> es)
|
||||||
|
=> Eff es ()
|
||||||
|
eatApple = do
|
||||||
|
(worldState . apple) .= Nothing
|
||||||
|
(worldState . snake . growth) %= (+) 3
|
||||||
|
genApple
|
||||||
|
|
||||||
|
isGameOver
|
||||||
|
:: (State GameState :> es)
|
||||||
|
=> Eff es Bool
|
||||||
|
isGameOver = do
|
||||||
|
gets @GameState (\s -> s.worldState.snake.head `elem` s.worldState.snake.body)
|
||||||
|
|
||||||
|
step
|
||||||
|
:: (State GameState :> es, Reader GameConfig :> es, State StdGen :> es, IOE :> es)
|
||||||
|
=> Eff es ()
|
||||||
|
step =
|
||||||
|
gets @GameState (\s -> s.reverseTime) >>=
|
||||||
|
\case
|
||||||
|
True -> do
|
||||||
|
gets @GameState (\s -> s.pastWorldStates) >>= \case
|
||||||
|
[] -> pure ()
|
||||||
|
[a] -> pure ()
|
||||||
|
_ -> do
|
||||||
|
worldState %.= \s -> Prelude.head . tail $ s.pastWorldStates
|
||||||
|
pastWorldStates %= \s -> tail s
|
||||||
|
False ->
|
||||||
|
gets @GameState (\s -> s.worldState.gameOver) >>= \case
|
||||||
|
False -> do
|
||||||
|
get @GameState >>= \state -> execState state.worldState.snake (moveSnake state.worldState.snake.direction) >>= (.=) (worldState . snake)
|
||||||
|
|
||||||
|
snakeHead <- gets @GameState (\s -> s.worldState.snake.head)
|
||||||
|
gets @GameState (\s -> s.worldState.apple) >>= \case
|
||||||
|
Just apple | apple == snakeHead -> eatApple
|
||||||
|
Nothing -> genApple
|
||||||
|
_ -> pure ()
|
||||||
|
|
||||||
|
whenM isGameOver $ do
|
||||||
|
(worldState . gameOver) .= True
|
||||||
|
liftIO . putStrLn $ "Game Over"
|
||||||
|
|
||||||
|
promoteWorldState
|
||||||
|
True -> pure ()
|
||||||
|
|
||||||
|
renderSprite
|
||||||
|
:: (IOE :> es)
|
||||||
|
=> SDL.Renderer
|
||||||
|
-> SDL.Texture
|
||||||
|
-> (Point, SDL.Rectangle CInt)
|
||||||
|
-> Eff es ()
|
||||||
|
renderSprite renderer texture (textureRect, rect) = SDL.copy renderer texture (Just (SDL.Rectangle (SDL.P (scalePoint 512 textureRect & pointToV2)) (SDL.V2 512 512))) (Just rect)
|
||||||
|
|
||||||
|
render
|
||||||
|
:: (State GameState :> es, IOE :> es, Reader GameConfig :> es)
|
||||||
|
=> SDL.Renderer
|
||||||
|
-> SDL.Texture
|
||||||
|
-> Eff es ()
|
||||||
|
render renderer texture = do
|
||||||
|
SDL.rendererDrawColor renderer $= SDL.V4 255 255 255 0
|
||||||
|
SDL.clear renderer
|
||||||
|
|
||||||
|
snake <- gets @GameState (\s -> s.worldState.snake)
|
||||||
|
snakeSprites <- renderSnake snake
|
||||||
|
mapM_ (renderSprite renderer texture) snakeSprites
|
||||||
|
|
||||||
|
gets @GameState (\s -> s.worldState.apple) >>= \case
|
||||||
|
Just apple -> renderApple apple >>= renderSprite renderer texture
|
||||||
|
Nothing -> pure ()
|
||||||
|
|
||||||
|
renderHead snake >>= renderSprite renderer texture
|
||||||
|
|
||||||
|
whenM (gets @GameState (\s -> s.worldState.gameOver)) $ pure () -- show text, but sdl_ttf sucks
|
||||||
|
|
||||||
|
SDL.present renderer
|
||||||
|
|
||||||
|
randomRange
|
||||||
|
:: (State StdGen :> es)
|
||||||
|
=> (Int, Int)
|
||||||
|
-> Eff es Int
|
||||||
|
randomRange range =
|
||||||
|
get @StdGen <&> uniformR range >>= \(a, g) -> put g >> pure a
|
||||||
|
|
||||||
|
getFreeSpaces
|
||||||
|
:: (State GameState :> es, Reader GameConfig :> es)
|
||||||
|
=> Eff es [Point]
|
||||||
|
getFreeSpaces = do
|
||||||
|
snakeBody <- gets @GameState (\s -> s.worldState.snake.body)
|
||||||
|
snakeHead <- gets @GameState (\s -> s.worldState.snake.head)
|
||||||
|
(width, height) <- asks @GameConfig (\s -> s.gridDimensions)
|
||||||
|
|
||||||
|
[0..(width * height)] & map (\i -> Point (i `rem` width) (i `div` width)) & filter (\point -> snakeHead /= point && point `notElem` snakeBody) & pure
|
||||||
|
|
||||||
|
genApple
|
||||||
|
:: (State GameState :> es, Reader GameConfig :> es, State StdGen :> es)
|
||||||
|
=> Eff es ()
|
||||||
|
genApple = do
|
||||||
|
freeSpaces <- getFreeSpaces
|
||||||
|
appleIndex <- randomRange (0, length freeSpaces - 1)
|
||||||
|
|
||||||
|
(worldState . apple) .= Just (freeSpaces !! appleIndex)
|
||||||
|
|
||||||
|
pure ()
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main =
|
||||||
|
let
|
||||||
|
rendererConfig
|
||||||
|
= SDL.defaultRenderer
|
||||||
|
{ SDL.rendererType = SDL.AcceleratedVSyncRenderer
|
||||||
|
}
|
||||||
|
windowConfig
|
||||||
|
= SDL.defaultWindow
|
||||||
|
{ SDL.windowInitialSize = SDL.V2 400 400
|
||||||
|
}
|
||||||
|
gameConfig
|
||||||
|
= GameConfig
|
||||||
|
{ gridDimensions = (20, 20)
|
||||||
|
, updatesPerSecond = 1
|
||||||
|
}
|
||||||
|
in
|
||||||
|
bracket (SDL.initialize [ SDL.InitEvents, SDL.InitVideo ]) (const SDL.quit) $ \_ ->
|
||||||
|
bracket (SDL.createWindow "Snake" windowConfig) SDL.destroyWindow $ \window ->
|
||||||
|
bracket (SDL.createRenderer window (-1) rendererConfig) SDL.destroyRenderer $ \renderer ->
|
||||||
|
initStdGen >>= \rng ->
|
||||||
|
SDLI.loadTexture renderer "textures/atlas.png" >>= \texture ->
|
||||||
|
|
||||||
|
runEff . runReader gameConfig . evalState initialGameState . evalState rng $ genApple >> promoteWorldState >> whileM do
|
||||||
|
SDL.rendererScale renderer $= SDL.V2 1.0 1.0
|
||||||
|
-- SDL.rendererViewport renderer $= Just (SDL.Rectangle 640 480)
|
||||||
|
events <- SDL.pollEvents
|
||||||
|
|
||||||
|
forM_ events \(SDL.Event _ payload) -> case payload of
|
||||||
|
SDL.KeyboardEvent (SDL.KeyboardEventData _ motion repeat (SDL.Keysym _ code modifier)) ->
|
||||||
|
case code of
|
||||||
|
SDL.KeycodeQ | motion == SDL.Pressed -> modify (run .~ False)
|
||||||
|
SDL.KeycodeEscape | motion == SDL.Pressed -> modify (run .~ False)
|
||||||
|
SDL.KeycodePeriod | motion == SDL.Pressed -> changeDirection North
|
||||||
|
SDL.KeycodeA | motion == SDL.Pressed -> changeDirection South
|
||||||
|
SDL.KeycodeH | motion == SDL.Pressed -> changeDirection West
|
||||||
|
SDL.KeycodeE | motion == SDL.Pressed -> changeDirection East
|
||||||
|
SDL.KeycodeComma -> setReversed (motion == SDL.Pressed)
|
||||||
|
_ -> pure ()
|
||||||
|
SDL.QuitEvent -> modify (run .~ False)
|
||||||
|
_ -> pure ()
|
||||||
|
|
||||||
|
|
||||||
|
frameNumber %= (+) 1
|
||||||
|
|
||||||
|
whenM (gets @GameState (\s -> s.frameNumber `rem` 60 == 0)) step
|
||||||
|
|
||||||
|
-- getFreeSpaces >>= liftIO . print
|
||||||
|
|
||||||
|
render renderer texture
|
||||||
|
|
||||||
|
gets @GameState (\s -> s.run)
|
1
snake/lib/Snake.hs
Normal file
1
snake/lib/Snake.hs
Normal file
|
@ -0,0 +1 @@
|
||||||
|
module Snake where
|
55
snake/package.yaml
Normal file
55
snake/package.yaml
Normal file
|
@ -0,0 +1,55 @@
|
||||||
|
name: snake
|
||||||
|
version: 0.1.0.0
|
||||||
|
|
||||||
|
# A short (one-line) description of the package.
|
||||||
|
# synopsis:
|
||||||
|
|
||||||
|
# A longer description of the package.
|
||||||
|
# description:
|
||||||
|
|
||||||
|
# A URL where users can report bugs.
|
||||||
|
# bug-reports:
|
||||||
|
|
||||||
|
# The license under which the package is released.
|
||||||
|
# license:
|
||||||
|
author: Magic_RB
|
||||||
|
maintainer: magic_rb@redalder.org
|
||||||
|
|
||||||
|
# A copyright notice.
|
||||||
|
# copyright:
|
||||||
|
# category:
|
||||||
|
|
||||||
|
dependencies:
|
||||||
|
- base
|
||||||
|
- unordered-containers
|
||||||
|
- bytestring
|
||||||
|
- text >= 2.0.1
|
||||||
|
- sdl2
|
||||||
|
- sdl2-image
|
||||||
|
- effectful-core
|
||||||
|
- extra
|
||||||
|
- lens
|
||||||
|
- vector
|
||||||
|
- random
|
||||||
|
other-extensions:
|
||||||
|
- ImportQualifiedPost
|
||||||
|
- OverloadedStrings
|
||||||
|
|
||||||
|
library:
|
||||||
|
verbatim:
|
||||||
|
default-language: GHC2021
|
||||||
|
source-dirs: lib
|
||||||
|
|
||||||
|
exposed-modules:
|
||||||
|
- Snake
|
||||||
|
|
||||||
|
executables:
|
||||||
|
snake:
|
||||||
|
ghc-options:
|
||||||
|
- -threaded
|
||||||
|
verbatim:
|
||||||
|
default-language: GHC2021
|
||||||
|
main: Main.hs
|
||||||
|
other-modules: []
|
||||||
|
source-dirs: app
|
||||||
|
dependencies: snake
|
58
snake/snake.cabal
Normal file
58
snake/snake.cabal
Normal file
|
@ -0,0 +1,58 @@
|
||||||
|
cabal-version: 1.12
|
||||||
|
|
||||||
|
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||||
|
--
|
||||||
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
|
name: snake
|
||||||
|
version: 0.1.0.0
|
||||||
|
author: Magic_RB
|
||||||
|
maintainer: magic_rb@redalder.org
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules:
|
||||||
|
Snake
|
||||||
|
other-modules:
|
||||||
|
Paths_snake
|
||||||
|
hs-source-dirs:
|
||||||
|
lib
|
||||||
|
other-extensions:
|
||||||
|
ImportQualifiedPost
|
||||||
|
OverloadedStrings
|
||||||
|
build-depends:
|
||||||
|
base
|
||||||
|
, bytestring
|
||||||
|
, effectful-core
|
||||||
|
, extra
|
||||||
|
, lens
|
||||||
|
, random
|
||||||
|
, sdl2
|
||||||
|
, sdl2-image
|
||||||
|
, text >=2.0.1
|
||||||
|
, unordered-containers
|
||||||
|
, vector
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
executable snake
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs:
|
||||||
|
app
|
||||||
|
other-extensions:
|
||||||
|
ImportQualifiedPost
|
||||||
|
OverloadedStrings
|
||||||
|
ghc-options: -threaded
|
||||||
|
build-depends:
|
||||||
|
base
|
||||||
|
, bytestring
|
||||||
|
, effectful-core
|
||||||
|
, extra
|
||||||
|
, lens
|
||||||
|
, random
|
||||||
|
, sdl2
|
||||||
|
, sdl2-image
|
||||||
|
, snake
|
||||||
|
, text >=2.0.1
|
||||||
|
, unordered-containers
|
||||||
|
, vector
|
||||||
|
default-language: GHC2021
|
BIN
snake/textures/atlas.png
Normal file
BIN
snake/textures/atlas.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 36 KiB |
278
snake/textures/atlas.svg
Normal file
278
snake/textures/atlas.svg
Normal file
|
@ -0,0 +1,278 @@
|
||||||
|
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
|
||||||
|
<!-- Created with Inkscape (http://www.inkscape.org/) -->
|
||||||
|
|
||||||
|
<svg
|
||||||
|
width="1024"
|
||||||
|
height="1536"
|
||||||
|
viewBox="0 0 270.93333 406.39999"
|
||||||
|
version="1.1"
|
||||||
|
id="svg5"
|
||||||
|
inkscape:version="1.2.2 (b0a8486541, 2022-12-01)"
|
||||||
|
sodipodi:docname="atlas.svg"
|
||||||
|
inkscape:export-filename="atlas.png"
|
||||||
|
inkscape:export-xdpi="96"
|
||||||
|
inkscape:export-ydpi="96"
|
||||||
|
xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
|
||||||
|
xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
|
||||||
|
xmlns:xlink="http://www.w3.org/1999/xlink"
|
||||||
|
xmlns="http://www.w3.org/2000/svg"
|
||||||
|
xmlns:svg="http://www.w3.org/2000/svg">
|
||||||
|
<sodipodi:namedview
|
||||||
|
id="namedview7"
|
||||||
|
pagecolor="#ffffff"
|
||||||
|
bordercolor="#666666"
|
||||||
|
borderopacity="1.0"
|
||||||
|
inkscape:showpageshadow="2"
|
||||||
|
inkscape:pageopacity="0.0"
|
||||||
|
inkscape:pagecheckerboard="0"
|
||||||
|
inkscape:deskcolor="#d1d1d1"
|
||||||
|
inkscape:document-units="mm"
|
||||||
|
showgrid="false"
|
||||||
|
showguides="true"
|
||||||
|
inkscape:zoom="1.2659148"
|
||||||
|
inkscape:cx="330.59097"
|
||||||
|
inkscape:cy="885.52563"
|
||||||
|
inkscape:window-width="2560"
|
||||||
|
inkscape:window-height="1565"
|
||||||
|
inkscape:window-x="0"
|
||||||
|
inkscape:window-y="35"
|
||||||
|
inkscape:window-maximized="1"
|
||||||
|
inkscape:current-layer="layer1">
|
||||||
|
<sodipodi:guide
|
||||||
|
position="0,270.93333"
|
||||||
|
orientation="0,1"
|
||||||
|
id="guide225"
|
||||||
|
inkscape:locked="false"
|
||||||
|
inkscape:label=""
|
||||||
|
inkscape:color="rgb(0,134,229)" />
|
||||||
|
<sodipodi:guide
|
||||||
|
position="135.46667,406.39999"
|
||||||
|
orientation="-1,0"
|
||||||
|
id="guide347"
|
||||||
|
inkscape:label=""
|
||||||
|
inkscape:locked="false"
|
||||||
|
inkscape:color="rgb(0,134,229)" />
|
||||||
|
<sodipodi:guide
|
||||||
|
position="135.46666,135.46666"
|
||||||
|
orientation="0,1"
|
||||||
|
id="guide1303"
|
||||||
|
inkscape:label=""
|
||||||
|
inkscape:locked="false"
|
||||||
|
inkscape:color="rgb(0,134,229)" />
|
||||||
|
</sodipodi:namedview>
|
||||||
|
<defs
|
||||||
|
id="defs2">
|
||||||
|
<clipPath
|
||||||
|
clipPathUnits="userSpaceOnUse"
|
||||||
|
id="clipPath1071">
|
||||||
|
<use
|
||||||
|
x="0"
|
||||||
|
y="0"
|
||||||
|
xlink:href="#g1067"
|
||||||
|
id="use1073" />
|
||||||
|
</clipPath>
|
||||||
|
<clipPath
|
||||||
|
clipPathUnits="userSpaceOnUse"
|
||||||
|
id="clipPath1147">
|
||||||
|
<use
|
||||||
|
x="0"
|
||||||
|
y="0"
|
||||||
|
xlink:href="#g1143"
|
||||||
|
id="use1149" />
|
||||||
|
</clipPath>
|
||||||
|
<clipPath
|
||||||
|
clipPathUnits="userSpaceOnUse"
|
||||||
|
id="clipPath1213">
|
||||||
|
<use
|
||||||
|
x="0"
|
||||||
|
y="0"
|
||||||
|
xlink:href="#g1209"
|
||||||
|
id="use1215" />
|
||||||
|
</clipPath>
|
||||||
|
</defs>
|
||||||
|
<g
|
||||||
|
inkscape:label="Head Right"
|
||||||
|
inkscape:groupmode="layer"
|
||||||
|
id="layer1">
|
||||||
|
<g
|
||||||
|
id="g1069"
|
||||||
|
clip-path="url(#clipPath1071)"
|
||||||
|
inkscape:label="Head"
|
||||||
|
transform="matrix(1.3333334,0,0,1.3333333,-22.577779,-22.577775)">
|
||||||
|
<g
|
||||||
|
inkscape:label="Clip"
|
||||||
|
id="g1067">
|
||||||
|
<path
|
||||||
|
sodipodi:type="star"
|
||||||
|
style="display:inline;fill:#0c8100;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:8.1707;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:markers fill stroke"
|
||||||
|
id="path1064"
|
||||||
|
inkscape:flatsided="false"
|
||||||
|
sodipodi:sides="3"
|
||||||
|
sodipodi:cx="35.891865"
|
||||||
|
sodipodi:cy="71.018372"
|
||||||
|
sodipodi:r1="64.884865"
|
||||||
|
sodipodi:r2="32.442432"
|
||||||
|
sodipodi:arg1="0"
|
||||||
|
sodipodi:arg2="1.0471976"
|
||||||
|
inkscape:rounded="0"
|
||||||
|
inkscape:randomized="0"
|
||||||
|
d="M 100.77673,71.018372 52.11308,99.114343 3.4494324,127.21031 l 0,-56.19194 0,-56.19194 48.6636496,28.095972 z"
|
||||||
|
inkscape:transform-center-x="-16.933334"
|
||||||
|
transform="matrix(1.0439003,0,0,0.90404423,13.33247,3.5295814)"
|
||||||
|
inkscape:transform-center-y="1.8573798e-06"
|
||||||
|
inkscape:label="path279" />
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
<g
|
||||||
|
inkscape:label="Head Down"
|
||||||
|
inkscape:groupmode="layer"
|
||||||
|
id="g1311"
|
||||||
|
transform="translate(5.9371192e-6,270.93334)">
|
||||||
|
<g
|
||||||
|
id="g1309"
|
||||||
|
clip-path="url(#clipPath1071)"
|
||||||
|
inkscape:label="Head"
|
||||||
|
transform="matrix(0,1.3333335,-1.3333333,0,158.04444,-22.577788)">
|
||||||
|
<g
|
||||||
|
inkscape:label="Clip"
|
||||||
|
id="g1307">
|
||||||
|
<path
|
||||||
|
sodipodi:type="star"
|
||||||
|
style="display:inline;fill:#0c8100;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:8.1707;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:markers fill stroke"
|
||||||
|
id="path1305"
|
||||||
|
inkscape:flatsided="false"
|
||||||
|
sodipodi:sides="3"
|
||||||
|
sodipodi:cx="35.891865"
|
||||||
|
sodipodi:cy="71.018372"
|
||||||
|
sodipodi:r1="64.884865"
|
||||||
|
sodipodi:r2="32.442432"
|
||||||
|
sodipodi:arg1="0"
|
||||||
|
sodipodi:arg2="1.0471976"
|
||||||
|
inkscape:rounded="0"
|
||||||
|
inkscape:randomized="0"
|
||||||
|
d="M 100.77673,71.018372 52.11308,99.114343 3.4494324,127.21031 l 0,-56.19194 0,-56.19194 48.6636496,28.095972 z"
|
||||||
|
inkscape:transform-center-x="-16.933334"
|
||||||
|
transform="matrix(1.0439003,0,0,0.90404423,13.33247,3.5295814)"
|
||||||
|
inkscape:transform-center-y="1.8573798e-06"
|
||||||
|
inkscape:label="path279" />
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
<g
|
||||||
|
inkscape:label="Head Left"
|
||||||
|
inkscape:groupmode="layer"
|
||||||
|
id="g1319"
|
||||||
|
transform="rotate(90,67.733321,203.19998)">
|
||||||
|
<g
|
||||||
|
id="g1317"
|
||||||
|
clip-path="url(#clipPath1071)"
|
||||||
|
inkscape:label="Head"
|
||||||
|
transform="matrix(0,1.3333335,-1.3333333,0,158.04444,-22.577788)">
|
||||||
|
<g
|
||||||
|
inkscape:label="Clip"
|
||||||
|
id="g1315">
|
||||||
|
<path
|
||||||
|
sodipodi:type="star"
|
||||||
|
style="display:inline;fill:#0c8100;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:8.1707;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:markers fill stroke"
|
||||||
|
id="path1313"
|
||||||
|
inkscape:flatsided="false"
|
||||||
|
sodipodi:sides="3"
|
||||||
|
sodipodi:cx="35.891865"
|
||||||
|
sodipodi:cy="71.018372"
|
||||||
|
sodipodi:r1="64.884865"
|
||||||
|
sodipodi:r2="32.442432"
|
||||||
|
sodipodi:arg1="0"
|
||||||
|
sodipodi:arg2="1.0471976"
|
||||||
|
inkscape:rounded="0"
|
||||||
|
inkscape:randomized="0"
|
||||||
|
d="M 100.77673,71.018372 52.11308,99.114343 3.4494324,127.21031 l 0,-56.19194 0,-56.19194 48.6636496,28.095972 z"
|
||||||
|
inkscape:transform-center-x="-16.933334"
|
||||||
|
transform="matrix(1.0439003,0,0,0.90404423,13.33247,3.5295814)"
|
||||||
|
inkscape:transform-center-y="1.8573798e-06"
|
||||||
|
inkscape:label="path279" />
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
<g
|
||||||
|
inkscape:label="Head Up"
|
||||||
|
inkscape:groupmode="layer"
|
||||||
|
id="g1327"
|
||||||
|
transform="rotate(180,203.19998,203.19999)">
|
||||||
|
<g
|
||||||
|
id="g1325"
|
||||||
|
clip-path="url(#clipPath1071)"
|
||||||
|
inkscape:label="Head"
|
||||||
|
transform="matrix(0,1.3333335,-1.3333333,0,293.5111,-22.577788)">
|
||||||
|
<g
|
||||||
|
inkscape:label="Clip"
|
||||||
|
id="g1323">
|
||||||
|
<path
|
||||||
|
sodipodi:type="star"
|
||||||
|
style="display:inline;fill:#0c8100;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:8.1707;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:markers fill stroke"
|
||||||
|
id="path1321"
|
||||||
|
inkscape:flatsided="false"
|
||||||
|
sodipodi:sides="3"
|
||||||
|
sodipodi:cx="35.891865"
|
||||||
|
sodipodi:cy="71.018372"
|
||||||
|
sodipodi:r1="64.884865"
|
||||||
|
sodipodi:r2="32.442432"
|
||||||
|
sodipodi:arg1="0"
|
||||||
|
sodipodi:arg2="1.0471976"
|
||||||
|
inkscape:rounded="0"
|
||||||
|
inkscape:randomized="0"
|
||||||
|
d="M 100.77673,71.018372 52.11308,99.114343 3.4494324,127.21031 l 0,-56.19194 0,-56.19194 48.6636496,28.095972 z"
|
||||||
|
inkscape:transform-center-x="-16.933334"
|
||||||
|
transform="matrix(1.0439003,0,0,0.90404423,13.33247,3.5295814)"
|
||||||
|
inkscape:transform-center-y="1.8573798e-06"
|
||||||
|
inkscape:label="path279" />
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
<g
|
||||||
|
inkscape:groupmode="layer"
|
||||||
|
id="layer2"
|
||||||
|
inkscape:label="Body">
|
||||||
|
<g
|
||||||
|
id="g1145"
|
||||||
|
clip-path="url(#clipPath1147)"
|
||||||
|
style="stroke-width:7.9375;stroke-dasharray:none"
|
||||||
|
transform="matrix(1.3036241,0,0,1.3333334,-60.187209,-22.577775)">
|
||||||
|
<g
|
||||||
|
inkscape:label="Clip"
|
||||||
|
id="g1143"
|
||||||
|
style="stroke-width:7.9375;stroke-dasharray:none">
|
||||||
|
<rect
|
||||||
|
style="fill:#0c8100;fill-opacity:1;stroke:#000000;stroke-width:7.9375;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:markers fill stroke"
|
||||||
|
id="rect1140"
|
||||||
|
width="103.91543"
|
||||||
|
height="101.6"
|
||||||
|
x="150.08458"
|
||||||
|
y="16.933331"
|
||||||
|
inkscape:label="rect1140" />
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
<g
|
||||||
|
inkscape:groupmode="layer"
|
||||||
|
id="layer3"
|
||||||
|
inkscape:label="Apple">
|
||||||
|
<g
|
||||||
|
id="g1211"
|
||||||
|
clip-path="url(#clipPath1213)"
|
||||||
|
style="fill:#d80000;fill-opacity:1;stroke-width:7.9375;stroke-dasharray:none"
|
||||||
|
transform="matrix(1.3333334,0,0,1.3333334,-22.577775,-67.733344)">
|
||||||
|
<g
|
||||||
|
inkscape:label="Clip"
|
||||||
|
id="g1209"
|
||||||
|
style="fill:#d80000;fill-opacity:1;stroke-width:7.9375;stroke-dasharray:none">
|
||||||
|
<circle
|
||||||
|
style="fill:#d80000;fill-opacity:1;stroke:#000000;stroke-width:7.9375;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1;paint-order:markers fill stroke"
|
||||||
|
id="path1204"
|
||||||
|
cx="67.73333"
|
||||||
|
cy="203.2"
|
||||||
|
r="50.799999" />
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
</g>
|
||||||
|
</svg>
|
After Width: | Height: | Size: 9.3 KiB |
66
stack.yaml
Normal file
66
stack.yaml
Normal file
|
@ -0,0 +1,66 @@
|
||||||
|
# This file was automatically generated by 'stack init'
|
||||||
|
#
|
||||||
|
# Some commonly used options have been documented as comments in this file.
|
||||||
|
# For advanced use and comprehensive documentation of the format, please see:
|
||||||
|
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||||
|
|
||||||
|
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||||
|
# A snapshot resolver dictates the compiler version and the set of packages
|
||||||
|
# to be used for project dependencies. For example:
|
||||||
|
#
|
||||||
|
# resolver: lts-3.5
|
||||||
|
# resolver: nightly-2015-09-21
|
||||||
|
# resolver: ghc-7.10.2
|
||||||
|
#
|
||||||
|
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||||
|
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||||
|
#
|
||||||
|
# resolver: ./custom-snapshot.yaml
|
||||||
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
|
resolver: nightly-2023-09-22
|
||||||
|
|
||||||
|
# User packages to be built.
|
||||||
|
# Various formats can be used as shown in the example below.
|
||||||
|
#
|
||||||
|
# packages:
|
||||||
|
# - some-directory
|
||||||
|
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||||
|
# subdirs:
|
||||||
|
# - auto-update
|
||||||
|
# - wai
|
||||||
|
packages:
|
||||||
|
- snake
|
||||||
|
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||||
|
# These entries can reference officially published versions as well as
|
||||||
|
# forks / in-progress versions pinned to a git hash. For example:
|
||||||
|
#
|
||||||
|
# extra-deps:
|
||||||
|
# - acme-missiles-0.3
|
||||||
|
# - git: https://github.com/commercialhaskell/stack.git
|
||||||
|
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||||
|
#
|
||||||
|
# extra-deps: []
|
||||||
|
|
||||||
|
# Override default flag values for local packages and extra-deps
|
||||||
|
# flags: {}
|
||||||
|
|
||||||
|
# Extra package databases containing global packages
|
||||||
|
# extra-package-dbs: []
|
||||||
|
|
||||||
|
# Control whether we use the GHC we find on the path
|
||||||
|
# system-ghc: true
|
||||||
|
#
|
||||||
|
# Require a specific version of Stack, using version ranges
|
||||||
|
# require-stack-version: -any # Default
|
||||||
|
# require-stack-version: ">=2.11"
|
||||||
|
#
|
||||||
|
# Override the architecture used by Stack, especially useful on Windows
|
||||||
|
# arch: i386
|
||||||
|
# arch: x86_64
|
||||||
|
#
|
||||||
|
# Extra directories used by Stack for building
|
||||||
|
# extra-include-dirs: [/path/to/dir]
|
||||||
|
# extra-lib-dirs: [/path/to/dir]
|
||||||
|
#
|
||||||
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
|
# compiler-check: newer-minor
|
12
stack.yaml.lock
Normal file
12
stack.yaml.lock
Normal file
|
@ -0,0 +1,12 @@
|
||||||
|
# This file was autogenerated by Stack.
|
||||||
|
# You should not edit this file by hand.
|
||||||
|
# For more information, please see the documentation at:
|
||||||
|
# https://docs.haskellstack.org/en/stable/lock_files
|
||||||
|
|
||||||
|
packages: []
|
||||||
|
snapshots:
|
||||||
|
- completed:
|
||||||
|
sha256: 93137bc0122de394fa2c43e933971b2996cd7dc600989b721ad971810b9a2f3f
|
||||||
|
size: 669537
|
||||||
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2023/9/22.yaml
|
||||||
|
original: nightly-2023-09-22
|
Loading…
Reference in a new issue