commit 1849375d7d9565228931aae8d6548ed967af41c5 Author: Magic_RB Date: Mon Sep 25 15:25:46 2023 +0200 Snake in Haskell diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..3550a30 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..98af07a --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.direnv +result* +.stack-work diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..d3c081f --- /dev/null +++ b/flake.lock @@ -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 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..96d5d3b --- /dev/null +++ b/flake.nix @@ -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 + ]; + }; + } + ); + }; +} diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..8ecd6c1 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,7 @@ +cradle: + stack: + - path: "snake/lib" + component: "snake:lib" + + - path: "snake/app/Main.hs" + component: "snake:exe:snake" diff --git a/snake/app/Main.hs b/snake/app/Main.hs new file mode 100644 index 0000000..defcdb5 --- /dev/null +++ b/snake/app/Main.hs @@ -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) diff --git a/snake/lib/Snake.hs b/snake/lib/Snake.hs new file mode 100644 index 0000000..7b7917b --- /dev/null +++ b/snake/lib/Snake.hs @@ -0,0 +1 @@ +module Snake where diff --git a/snake/package.yaml b/snake/package.yaml new file mode 100644 index 0000000..56f5cdb --- /dev/null +++ b/snake/package.yaml @@ -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 diff --git a/snake/snake.cabal b/snake/snake.cabal new file mode 100644 index 0000000..b7e6c87 --- /dev/null +++ b/snake/snake.cabal @@ -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 diff --git a/snake/textures/atlas.png b/snake/textures/atlas.png new file mode 100644 index 0000000..8767701 Binary files /dev/null and b/snake/textures/atlas.png differ diff --git a/snake/textures/atlas.svg b/snake/textures/atlas.svg new file mode 100644 index 0000000..3e665b7 --- /dev/null +++ b/snake/textures/atlas.svg @@ -0,0 +1,278 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..05f9507 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..178774f --- /dev/null +++ b/stack.yaml.lock @@ -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