Snake movement

app/Graphics.hs

@@ -5,45 +5,42 @@ module Graphics (
 import SDL
 import SnakeLib
 import Foreign.C (CInt)
-import Data.Array (indices)
+import Data.Array (assocs)
 import Control.Monad (void)
 
-renderFrame :: Renderer -> Texture -> IO ()
+renderFrame :: Renderer -> Texture -> Game -> IO ()
-renderFrame renderer texture = do
+renderFrame renderer texture game = do
     rendererDrawColor renderer $= V4 32 32 32 255
     clear renderer
     rendererDrawColor renderer $= V4 255 255 255 255
-    renderState renderer texture $ initialState (20, 20) (2, 2)
+    renderGame renderer texture game
     present renderer
 
-renderState :: Renderer -> Texture -> GameState -> IO ()
+renderGame :: Renderer -> Texture -> Game -> IO ()
-renderState renderer texture state = do
+renderGame renderer texture state = do
-    void $ traverse (renderTile renderer texture state) (indices $ gameBoard state)
+    void $ traverse (renderTile renderer texture) (assocs $ gameBoard state)
 
-renderTile :: Renderer -> Texture -> GameState -> Pos -> IO ()
+renderTile :: Renderer -> Texture -> (Pos, Tile) -> IO ()
-renderTile renderer texture state pos = case tileAt (gameBoard state) pos of
+renderTile renderer texture (pos, tile) = case tile of
     Empty -> return ()
     Apple -> renderSpriteAt renderer texture APPLE pos
-    Snake -> 
+    Snake orientation -> renderSpriteAt renderer texture (snakeSprite orientation) pos
-        let size = gameBoardSize state
-        in renderSpriteAt renderer texture (snakeSprite (neighborTiles size (gameBoard state) pos) (pos == snakeHead state))pos
 
-snakeSprite :: (Tile, Tile, Tile, Tile) -> Bool -> Sprite
+snakeSprite :: SnakeOrientation -> Sprite
-snakeSprite (Snake, _, _, _) True = SNAKE_HEAD_DOWN
+snakeSprite HEAD_DOWN = SNAKE_HEAD_DOWN
-snakeSprite (_, Snake, _, _) True = SNAKE_HEAD_LEFT
+snakeSprite HEAD_LEFT = SNAKE_HEAD_LEFT
-snakeSprite (_, _, Snake, _) True = SNAKE_HEAD_UP
+snakeSprite HEAD_UP = SNAKE_HEAD_UP
-snakeSprite (_, _, _, Snake) True = SNAKE_HEAD_RIGHT
+snakeSprite HEAD_RIGHT = SNAKE_HEAD_RIGHT
-snakeSprite (Snake, _, Snake, _) _ = SNAKE_VERTICAL
+snakeSprite VERTICAL = SNAKE_VERTICAL
-snakeSprite (_, Snake, _, Snake) _ = SNAKE_HORIZONTAL
+snakeSprite HORIZONTAL = SNAKE_HORIZONTAL
-snakeSprite (Snake, Snake, _, _) _ = SNAKE_TURN_UP_RIGHT
+snakeSprite TURN_UP_RIGHT = SNAKE_TURN_UP_RIGHT
-snakeSprite (_, Snake, Snake, _) _ = SNAKE_TURN_DOWN_RIGHT
+snakeSprite TURN_DOWN_RIGHT = SNAKE_TURN_DOWN_RIGHT
-snakeSprite (_, _, Snake, Snake) _ = SNAKE_TURN_DOWN_LEFT
+snakeSprite TURN_DOWN_LEFT = SNAKE_TURN_DOWN_LEFT
-snakeSprite (Snake, _, _, Snake) _ = SNAKE_TURN_UP_LEFT
+snakeSprite TURN_UP_LEFT = SNAKE_TURN_UP_LEFT
-snakeSprite (Snake, _, _, _) _ = SNAKE_TAIL_UP
+snakeSprite TAIL_UP = SNAKE_TAIL_UP
-snakeSprite (_, Snake, _, _) _ = SNAKE_TAIL_RIGHT
+snakeSprite TAIL_RIGHT = SNAKE_TAIL_RIGHT
-snakeSprite (_, _, Snake, _) _ = SNAKE_TAIL_DOWN
+snakeSprite TAIL_DOWN = SNAKE_TAIL_DOWN
-snakeSprite (_, _, _, Snake) _ = SNAKE_TAIL_LEFT
+snakeSprite TAIL_LEFT = SNAKE_TAIL_LEFT
-snakeSprite _ _ = APPLE
 
 renderSpriteAt :: Renderer -> Texture -> Sprite -> (Int, Int) -> IO ()
 renderSpriteAt renderer texture sprite (x, y) = do

app/Main.hs

@@ -17,20 +17,20 @@ main = do
     
     texture <- IMG.loadTexture renderer "assets/spritesheet.png"
 
-    appLoop renderer texture
+    appLoop renderer texture (initialState (20, 20) (2, 2))
 
     destroyTexture texture
     destroyRenderer renderer
     destroyWindow window
 
 targetFps :: Word32
-targetFps = 60
+targetFps = 2
 
 targetFrameMs :: Word32
 targetFrameMs = 1000 `div` targetFps
 
-appLoop :: Renderer -> Texture -> IO ()
+appLoop :: Renderer -> Texture -> Game -> IO ()
-appLoop renderer texture = do
+appLoop renderer texture game = do
     frameStart <- getTicks
     events <- pollEvents
     let eventIsExitPress event = case eventPayload event of
@@ -40,9 +40,29 @@ appLoop renderer texture = do
           WindowClosedEvent _ -> True
           _ -> False
         exitPressed = any eventIsExitPress events
-    renderFrame renderer texture
+    let eventDirectionPressed event = case eventPayload event of
+          KeyboardEvent keyboardEvent -> 
+            if keyboardEventKeyMotion keyboardEvent == Pressed 
+                then getInputByKeycode $ keysymKeycode (keyboardEventKeysym keyboardEvent) 
+                else NothingPressed
+          _ -> NothingPressed
+        input = foldMap eventDirectionPressed events
     frameEnd <- getTicks
     let elapsed = frameEnd - frameStart
-    delay (targetFrameMs - elapsed)
+    let updatedGame = execTick game input
-    unless exitPressed (appLoop renderer texture)
+    renderFrame renderer texture updatedGame
     
+    unless exitPressed $ do 
+        delay (targetFrameMs - elapsed)
+        appLoop renderer texture updatedGame
+
+getInputByKeycode :: Keycode -> MovementInput
+getInputByKeycode KeycodeW = UpPressed
+getInputByKeycode KeycodeUp = UpPressed
+getInputByKeycode KeycodeD = RightPressed
+getInputByKeycode KeycodeRight = RightPressed
+getInputByKeycode KeycodeS = DownPressed
+getInputByKeycode KeycodeDown = DownPressed
+getInputByKeycode KeycodeA = LeftPressed
+getInputByKeycode KeycodeLeft = LeftPressed
+getInputByKeycode _ = NothingPressed

snake-hs.cabal

@@ -69,6 +69,7 @@ library
     -- Other library packages from which modules are imported.
     build-depends:
         base ^>=4.20.2.0,
+        mtl,
         array
 
     -- Directories containing source files.

src/SnakeLib.hs

@@ -5,17 +5,30 @@ module SnakeLib (
     Board,
     tileAt,
     wrapPos,
-    neighborTiles,
 
-    GameState (..),
+    Game (..),
-    initialState
+    initialState,
+
+    execTick,
+
+    SnakeOrientation (..)
 ) where
 
 import Data.Array
+import Control.Monad.State
+import Control.Monad (when)
 
-data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed
+data MovementInput = UpPressed | RightPressed | DownPressed | LeftPressed | NothingPressed deriving (Eq, Show)
 
-data Tile = Snake | Apple | Empty
+instance Semigroup MovementInput where
+    (<>) l NothingPressed = l
+    NothingPressed <> r = r
+    l <> _ = l
+
+instance Monoid MovementInput where
+    mempty = NothingPressed
+
+data Tile = Snake SnakeOrientation | Apple | Empty
 
 type Pos = (Int, Int)
 type Board = Array Pos Tile
@@ -27,21 +40,156 @@ wrapPos :: (Int, Int) -> Pos -> Pos
 wrapPos (w, h) (x, y) =
   (x `mod` w, y `mod` h)
 
-neighborTiles :: (Int, Int) -> Board -> Pos -> (Tile, Tile, Tile, Tile)
+data Game = Game {gameBoard :: Board, gameBoardSize :: (Int, Int), snakeHead :: Pos, snakeTail :: Pos}
-neighborTiles size board (x, y) =
-  ( tileAt board (wrapPos size (x, y - 1))  -- up
-  , tileAt board (wrapPos size (x + 1, y))  -- right
-  , tileAt board (wrapPos size (x, y + 1))  -- down
-  , tileAt board (wrapPos size (x - 1, y))  -- left
-  )
 
-data GameState = GameState {gameBoard :: Board, gameBoardSize :: (Int, Int), snakeHead :: Pos}
+type GameState = State Game
 
 emptyBoard :: (Int, Int) -> Array (Int, Int) Tile
 emptyBoard (w, h) = array ((0, 0), (w-1, h-1)) [((i, j), Empty) | i <- [0..w-1], j <- [0..h-1]]
 
-initialState :: (Int, Int) -> (Int, Int) -> GameState
+initialState :: (Int, Int) -> (Int, Int) -> Game
-initialState size (x, y) = GameState {gameBoard=(emptyBoard size) // [((x-1, y), Snake), ((x, y), Snake)], gameBoardSize=size, snakeHead=(x, y)}
+initialState size (x, y) = Game 
+    { gameBoard=(emptyBoard size) // [((x-1, y), Snake TAIL_RIGHT), ((x, y), Snake HEAD_RIGHT)]
+    , gameBoardSize=size
+    , snakeHead=(x, y)
+    , snakeTail=(x-1, y)}
 
-gameTick :: GameState -> MovementInput -> GameState
+execTick :: Game -> MovementInput -> Game
-gameTick = undefined
+execTick game input = execState (gameTick input) game
+
+gameTick :: MovementInput -> GameState MovementResult
+gameTick input = do
+    movementResult <- advanceSnake input
+    when (movementResult == IntoEmpty) shrinkSnake
+    pure movementResult
+
+advanceSnake :: MovementInput -> GameState MovementResult
+advanceSnake input = do
+    idleDirection <- headDirection
+    let inputDirection = case input of 
+            UpPressed -> UP
+            RightPressed -> RIGHT
+            DownPressed -> DOWN
+            LeftPressed -> LEFT
+            NothingPressed -> idleDirection
+    let direction = if areOpposite idleDirection inputDirection then idleDirection else inputDirection
+    pos <- gets snakeHead
+    destination <- shiftPos pos direction
+    destinationTile <- gets ((`tileAt` destination) . gameBoard)
+    case destinationTile of
+        Apple -> moveHead direction >> pure IntoApple
+        Empty -> moveHead direction >> pure IntoEmpty
+        Snake _ -> pure IntoSnake
+
+headDirection :: GameState Direction
+headDirection = gets f
+    where 
+        f :: Game -> Direction
+        f game = case tileAt (gameBoard game) (snakeHead game) of
+            Snake HEAD_DOWN -> DOWN
+            Snake HEAD_LEFT -> LEFT
+            Snake HEAD_UP -> UP
+            Snake HEAD_RIGHT -> RIGHT
+            _ -> error "Invalid snake head tile"
+
+moveHead :: Direction -> GameState ()
+moveHead direction = do 
+    pos <- gets snakeHead
+    destination <- shiftPos pos direction
+    board <- gets gameBoard
+    headTile <- gets ((`tileAt` pos) . gameBoard)
+    let orientation = case headTile of 
+            Snake x -> x
+            _ -> error "Invalid snake head tile"
+    let modifiedBoard = board // [(pos, Snake $ getGrownHead orientation direction), (destination, Snake $ getNewHead direction)]
+    modify (\s -> s {gameBoard=modifiedBoard, snakeHead=destination})
+
+getGrownHead :: SnakeOrientation -> Direction -> SnakeOrientation
+getGrownHead HEAD_UP UP = VERTICAL
+getGrownHead HEAD_UP LEFT = TURN_DOWN_LEFT
+getGrownHead HEAD_UP RIGHT = TURN_DOWN_RIGHT
+getGrownHead HEAD_RIGHT RIGHT = HORIZONTAL
+getGrownHead HEAD_RIGHT UP = TURN_UP_LEFT
+getGrownHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT
+getGrownHead HEAD_DOWN DOWN = VERTICAL
+getGrownHead HEAD_DOWN RIGHT = TURN_UP_RIGHT
+getGrownHead HEAD_DOWN LEFT = TURN_UP_LEFT
+getGrownHead HEAD_LEFT LEFT = HORIZONTAL
+getGrownHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT
+getGrownHead HEAD_LEFT UP = TURN_UP_RIGHT
+getGrownHead _ _ = error "Invalid getGrownHead arguments"
+
+getNewHead :: Direction -> SnakeOrientation
+getNewHead UP = HEAD_UP
+getNewHead RIGHT = HEAD_RIGHT
+getNewHead DOWN = HEAD_DOWN
+getNewHead LEFT = HEAD_LEFT
+
+shiftPos :: Pos -> Direction -> GameState Pos
+shiftPos (x, y) direction = do
+    let (dx, dy) = getDelta direction
+    size <- gets gameBoardSize
+    pure $ wrapPos size (x + dx, y + dy)
+    
+
+shrinkSnake :: GameState ()
+shrinkSnake = do
+    pos <- gets snakeTail
+    tile <- gets ((`tileAt` pos) . gameBoard)
+    let direction = case tile of
+            Snake TAIL_UP -> UP
+            Snake TAIL_RIGHT -> RIGHT
+            Snake TAIL_DOWN -> DOWN
+            Snake TAIL_LEFT -> LEFT
+            _ -> error "Invalid snake tail tile"
+    destination <- shiftPos pos direction
+    board <- gets gameBoard
+    destinationTile <- gets ((`tileAt` destination) . gameBoard)
+    let orientation = case destinationTile of 
+            Snake x -> x
+            _ -> error "Invalid snake segment tile"
+    let modifiedBoard = board // [(pos, Empty), (destination, Snake $ getNewTail orientation direction)]
+    modify (\s -> s {gameBoard=modifiedBoard, snakeTail=destination})
+
+getNewTail :: SnakeOrientation -> Direction -> SnakeOrientation
+getNewTail HEAD_UP UP = TAIL_UP
+getNewTail HEAD_RIGHT RIGHT = TAIL_RIGHT
+getNewTail HEAD_DOWN DOWN = TAIL_DOWN
+getNewTail HEAD_LEFT LEFT = TAIL_LEFT
+getNewTail TURN_UP_RIGHT LEFT = TAIL_UP
+getNewTail TURN_UP_RIGHT DOWN = TAIL_RIGHT
+getNewTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN
+getNewTail TURN_DOWN_RIGHT UP = TAIL_RIGHT
+getNewTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN
+getNewTail TURN_DOWN_LEFT UP = TAIL_LEFT
+getNewTail TURN_UP_LEFT RIGHT = TAIL_UP
+getNewTail TURN_UP_LEFT DOWN = TAIL_LEFT
+getNewTail HORIZONTAL RIGHT = TAIL_RIGHT
+getNewTail HORIZONTAL LEFT = TAIL_LEFT
+getNewTail VERTICAL UP = TAIL_UP
+getNewTail VERTICAL DOWN = TAIL_DOWN
+getNewTail o d = error ("Invalid getNewTail arguments: " ++ show o ++ " " ++ show d)
+
+data MovementResult = IntoApple | IntoSnake | IntoEmpty deriving (Eq, Show)
+
+data SnakeOrientation =
+    HEAD_DOWN | HEAD_LEFT | HEAD_UP | HEAD_RIGHT |
+    TURN_UP_RIGHT | TURN_DOWN_RIGHT | TURN_DOWN_LEFT | TURN_UP_LEFT |
+    VERTICAL | HORIZONTAL |
+    TAIL_UP | TAIL_RIGHT | TAIL_DOWN | TAIL_LEFT
+    deriving (Eq, Show)
+
+data Direction = DOWN | LEFT | UP | RIGHT deriving (Eq, Show)
+
+areOpposite :: Direction -> Direction -> Bool
+areOpposite UP DOWN = True
+areOpposite DOWN UP = True
+areOpposite LEFT RIGHT = True
+areOpposite RIGHT LEFT = True
+areOpposite _ _ = False
+
+getDelta :: Direction -> (Int, Int)
+getDelta UP = (0, -1)
+getDelta RIGHT = (1, 0)
+getDelta DOWN = (0, 1)
+getDelta LEFT = (-1, 0)