diff --git a/app/Main.hs b/app/Main.hs index b553bc2..c950c07 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,7 +24,7 @@ main = do destroyWindow window targetFps :: Word32 -targetFps = 2 +targetFps = 5 targetFrameMs :: Word32 targetFrameMs = 1000 `div` targetFps diff --git a/snake-hs.cabal b/snake-hs.cabal index b21abd0..ff0f3fc 100644 --- a/snake-hs.cabal +++ b/snake-hs.cabal @@ -70,6 +70,7 @@ library build-depends: base ^>=4.20.2.0, mtl, + random, array -- Directories containing source files. @@ -132,4 +133,7 @@ test-suite snake-hs-test -- Test dependencies. build-depends: base ^>=4.20.2.0, - snake-hs + array, + snake-hs, + tasty, + tasty-hunit diff --git a/src/SnakeLib.hs b/src/SnakeLib.hs index 0c5d7ce..c232eee 100644 --- a/src/SnakeLib.hs +++ b/src/SnakeLib.hs @@ -10,14 +10,18 @@ module SnakeLib ( runTick, - SnakeSegmentOrientation (..) + SnakeSegmentOrientation (..), + Direction (..), + growHead, + shrinkTail ) where import Data.Array import Control.Monad.State -import Control.Monad (when) +import Control.Monad (when, unless) +import System.Random (randomRIO) -data Tile = SnakeSegment SnakeSegmentOrientation | Apple | Empty +data Tile = SnakeSegment SnakeSegmentOrientation | Apple | Empty deriving (Eq, Show) type Pos = (Int, Int) @@ -30,7 +34,7 @@ emptyBoard (w, h) = array ((0, 0), (w-1, h-1)) [((i, j), Empty) | i <- [0..w-1], initialState :: (Int, Int) -> (Int, Int) -> Game initialState size (x, y) = Game - { gameBoard=(emptyBoard size) // [((x-1, y), SnakeSegment TAIL_RIGHT), ((x, y), SnakeSegment HEAD_RIGHT)] + { gameBoard=(emptyBoard size) // [((x-1, y), SnakeSegment TAIL_RIGHT), ((x, y), SnakeSegment HEAD_RIGHT), ((x + 2, y), Apple), ((x + 3, y), Apple)] , gameBoardSize=size , snakeHead=(x, y) , snakeTail=(x-1, y)} @@ -42,6 +46,7 @@ gameTick :: (MonadState Game m, MonadIO m) => MovementInput -> m MovementResult gameTick input = do movementResult <- advanceSnake input when (movementResult == IntoEmpty) shrinkSnake + when (movementResult == IntoApple) spawnApple pure movementResult advanceSnake :: MonadState Game m => MovementInput -> m MovementResult @@ -82,23 +87,23 @@ moveHead direction = do let orientation = case headTile of SnakeSegment x -> x _ -> error "Invalid snake head tile" - let modifiedBoard = board // [(pos, SnakeSegment $ getGrownHead orientation direction), (destination, SnakeSegment $ getNewHead direction)] + let modifiedBoard = board // [(pos, SnakeSegment $ growHead orientation direction), (destination, SnakeSegment $ getNewHead direction)] modify (\s -> s {gameBoard=modifiedBoard, snakeHead=destination}) -getGrownHead :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation -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" +growHead :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation +growHead HEAD_UP UP = VERTICAL +growHead HEAD_UP LEFT = TURN_DOWN_LEFT +growHead HEAD_UP RIGHT = TURN_DOWN_RIGHT +growHead HEAD_RIGHT RIGHT = HORIZONTAL +growHead HEAD_RIGHT UP = TURN_UP_LEFT +growHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT +growHead HEAD_DOWN DOWN = VERTICAL +growHead HEAD_DOWN RIGHT = TURN_UP_RIGHT +growHead HEAD_DOWN LEFT = TURN_UP_LEFT +growHead HEAD_LEFT LEFT = HORIZONTAL +growHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT +growHead HEAD_LEFT UP = TURN_UP_RIGHT +growHead _ _ = error "Invalid growHead arguments" getNewHead :: Direction -> SnakeSegmentOrientation getNewHead UP = HEAD_UP @@ -122,27 +127,36 @@ shrinkSnake = do let orientation = case destinationTile of SnakeSegment x -> x _ -> error "Invalid snake segment tile" - let modifiedBoard = board // [(pos, Empty), (destination, SnakeSegment $ getNewTail orientation direction)] + let modifiedBoard = board // [(pos, Empty), (destination, SnakeSegment $ shrinkTail orientation direction)] modify (\s -> s {gameBoard=modifiedBoard, snakeTail=destination}) -getNewTail :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation -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) +shrinkTail :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation +shrinkTail HEAD_UP UP = TAIL_UP +shrinkTail HEAD_RIGHT RIGHT = TAIL_RIGHT +shrinkTail HEAD_DOWN DOWN = TAIL_DOWN +shrinkTail HEAD_LEFT LEFT = TAIL_LEFT +shrinkTail TURN_UP_RIGHT LEFT = TAIL_UP +shrinkTail TURN_UP_RIGHT DOWN = TAIL_RIGHT +shrinkTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN +shrinkTail TURN_DOWN_RIGHT UP = TAIL_RIGHT +shrinkTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN +shrinkTail TURN_DOWN_LEFT UP = TAIL_LEFT +shrinkTail TURN_UP_LEFT RIGHT = TAIL_UP +shrinkTail TURN_UP_LEFT DOWN = TAIL_LEFT +shrinkTail HORIZONTAL RIGHT = TAIL_RIGHT +shrinkTail HORIZONTAL LEFT = TAIL_LEFT +shrinkTail VERTICAL UP = TAIL_UP +shrinkTail VERTICAL DOWN = TAIL_DOWN +shrinkTail o d = error ("Invalid shrinkTail arguments: " ++ show o ++ " " ++ show d) + +spawnApple :: (MonadState Game m, MonadIO m) => m () +spawnApple = do + (w, h) <- gets gameBoardSize + pos <- liftIO $ randomRIO ((0, 0), (w - 1, h - 1)) + tile <- getTileAt pos + case tile of + Empty -> modify (\s -> s {gameBoard = gameBoard s // [(pos, Apple)]}) + _ -> spawnApple tileAt :: Board -> Pos -> Tile tileAt board (x, y) = (board ! (x, y)) diff --git a/test/Main.hs b/test/Main.hs index 3e2059e..b99cff1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,133 @@ module Main (main) where +import Data.Array (elems, (!)) +import SnakeLib +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + main :: IO () -main = putStrLn "Test suite not yet implemented." +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "SnakeLib" [ growHeadTests, shrinkTailTests, runTickTests] + +growHeadTests :: TestTree +growHeadTests = + testGroup "growHead" [ + orientationCase "HEAD_UP + UP" HEAD_UP UP VERTICAL, + orientationCase "HEAD_UP + LEFT" HEAD_UP LEFT TURN_DOWN_LEFT, + orientationCase "HEAD_UP + RIGHT" HEAD_UP RIGHT TURN_DOWN_RIGHT, + orientationCase "HEAD_RIGHT + RIGHT" HEAD_RIGHT RIGHT HORIZONTAL, + orientationCase "HEAD_RIGHT + UP" HEAD_RIGHT UP TURN_UP_LEFT, + orientationCase "HEAD_RIGHT + DOWN" HEAD_RIGHT DOWN TURN_DOWN_LEFT, + orientationCase "HEAD_DOWN + DOWN" HEAD_DOWN DOWN VERTICAL, + orientationCase "HEAD_DOWN + RIGHT" HEAD_DOWN RIGHT TURN_UP_RIGHT, + orientationCase "HEAD_DOWN + LEFT" HEAD_DOWN LEFT TURN_UP_LEFT, + orientationCase "HEAD_LEFT + LEFT" HEAD_LEFT LEFT HORIZONTAL, + orientationCase "HEAD_LEFT + DOWN" HEAD_LEFT DOWN TURN_DOWN_RIGHT, + orientationCase "HEAD_LEFT + UP" HEAD_LEFT UP TURN_UP_RIGHT + ] + where + orientationCase label headOrientation direction expected = + testCase label $ + assertEqual label expected (growHead headOrientation direction) + +shrinkTailTests :: TestTree +shrinkTailTests = + testGroup "shrinkTail" [ + orientationCase "HEAD_UP + UP" HEAD_UP UP TAIL_UP, + orientationCase "HEAD_RIGHT + RIGHT" HEAD_RIGHT RIGHT TAIL_RIGHT, + orientationCase "HEAD_DOWN + DOWN" HEAD_DOWN DOWN TAIL_DOWN, + orientationCase "HEAD_LEFT + LEFT" HEAD_LEFT LEFT TAIL_LEFT, + orientationCase "TURN_UP_RIGHT + LEFT" TURN_UP_RIGHT LEFT TAIL_UP, + orientationCase "TURN_UP_RIGHT + DOWN" TURN_UP_RIGHT DOWN TAIL_RIGHT, + orientationCase "TURN_DOWN_RIGHT + LEFT" TURN_DOWN_RIGHT LEFT TAIL_DOWN, + orientationCase "TURN_DOWN_RIGHT + UP" TURN_DOWN_RIGHT UP TAIL_RIGHT, + orientationCase "TURN_DOWN_LEFT + RIGHT" TURN_DOWN_LEFT RIGHT TAIL_DOWN, + orientationCase "TURN_DOWN_LEFT + UP" TURN_DOWN_LEFT UP TAIL_LEFT, + orientationCase "TURN_UP_LEFT + RIGHT" TURN_UP_LEFT RIGHT TAIL_UP, + orientationCase "TURN_UP_LEFT + DOWN" TURN_UP_LEFT DOWN TAIL_LEFT, + orientationCase "HORIZONTAL + RIGHT" HORIZONTAL RIGHT TAIL_RIGHT, + orientationCase "HORIZONTAL + LEFT" HORIZONTAL LEFT TAIL_LEFT, + orientationCase "VERTICAL + UP" VERTICAL UP TAIL_UP, + orientationCase "VERTICAL + DOWN" VERTICAL DOWN TAIL_DOWN + ] + where + orientationCase label tailOrientation direction expected = + testCase label $ + assertEqual label expected (shrinkTail tailOrientation direction) + +runTickTests :: TestTree +runTickTests = + testGroup "runTick" [ + testCase "initialState sets the starting snake and apples" $ + let game = initialState (10, 10) (3, 4) + board = gameBoard game + in do + assertEqual "snakeHead" (3, 4) (snakeHead game) + assertEqual "snakeTail" (2, 4) (snakeTail game) + assertEqual "tail tile" (SnakeSegment TAIL_RIGHT) (board ! (2, 4)) + assertEqual "head tile" (SnakeSegment HEAD_RIGHT) (board ! (3, 4)) + assertEqual "first apple" Apple (board ! (5, 4)) + assertEqual "second apple" Apple (board ! (6, 4)), + testCase "runTick with no input continues moving right" $ + let game = initialState (10, 10) (3, 4) + in do + (_, nextGame) <- runTick game NothingPressed + let board = gameBoard nextGame + assertEqual "snakeHead" (4, 4) (snakeHead nextGame) + assertEqual "snakeTail" (3, 4) (snakeTail nextGame) + assertEqual "new tail" (SnakeSegment TAIL_RIGHT) (board ! (3, 4)) + assertEqual "new head" (SnakeSegment HEAD_RIGHT) (board ! (4, 4)) + assertEqual "vacated tail" Empty (board ! (2, 4)), + testCase "runTick ignores opposite-direction input" $ + let game = initialState (10, 10) (3, 4) + in do + (_, nextGame) <- runTick game LeftPressed + let board = gameBoard nextGame + assertEqual "snakeHead" (4, 4) (snakeHead nextGame) + assertEqual "snakeTail" (3, 4) (snakeTail nextGame) + assertEqual "new tail" (SnakeSegment TAIL_RIGHT) (board ! (3, 4)) + assertEqual "new head" (SnakeSegment HEAD_RIGHT) (board ! (4, 4)), + testCase "runTick turns the snake when given a valid direction" $ + let game = initialState (10, 10) (3, 4) + in do + (_, nextGame) <- runTick game DownPressed + let board = gameBoard nextGame + assertEqual "snakeHead" (3, 5) (snakeHead nextGame) + assertEqual "snakeTail" (3, 4) (snakeTail nextGame) + assertEqual "new tail after turning" (SnakeSegment TAIL_DOWN) (board ! (3, 4)) + assertEqual "new head" (SnakeSegment HEAD_DOWN) (board ! (3, 5)) + assertEqual "vacated tail" Empty (board ! (2, 4)), + testCase "runTick grows the snake after eating an apple" $ + let game = initialState (10, 10) (3, 4) + initialSegments = snakeSegmentCount game + in do + (_, movedGame) <- runTick game NothingPressed + (_, grownGame) <- runTick movedGame NothingPressed + let board = gameBoard grownGame + assertEqual "snakeHead" (5, 4) (snakeHead grownGame) + assertEqual "snakeTail unchanged after growth" (3, 4) (snakeTail grownGame) + assertEqual "segment count increased" (initialSegments + 1) (snakeSegmentCount grownGame) + assertEqual "new body segment" (SnakeSegment HORIZONTAL) (board ! (4, 4)) + assertEqual "new head" (SnakeSegment HEAD_RIGHT) (board ! (5, 4)), + testCase "runTick wraps around the board edges" $ + let game = initialState (5, 5) (1, 3) + in do + (_, step1) <- runTick game UpPressed + (_, step2) <- runTick step1 NothingPressed + (_, step3) <- runTick step2 NothingPressed + (_, step4) <- runTick step3 NothingPressed + let board = gameBoard step4 + assertEqual "snakeHead" (1, 4) (snakeHead step4) + assertEqual "wrapped head tile" (SnakeSegment HEAD_UP) (board ! (1, 4)) + assertEqual "tail advanced" (1, 0) (snakeTail step4) + ] + +snakeSegmentCount :: Game -> Int +snakeSegmentCount = length . filter isSnakeSegment . elems . gameBoard + +isSnakeSegment :: Tile -> Bool +isSnakeSegment (SnakeSegment _) = True +isSnakeSegment _ = False