Tests

app/Main.hs

@@ -24,7 +24,7 @@ main = do
     destroyWindow window
 
 targetFps :: Word32
-targetFps = 2
+targetFps = 5
 
 targetFrameMs :: Word32
 targetFrameMs = 1000 `div` targetFps

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

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
+growHead :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation
-getGrownHead HEAD_UP UP = VERTICAL
+growHead HEAD_UP UP = VERTICAL
-getGrownHead HEAD_UP LEFT = TURN_DOWN_LEFT
+growHead HEAD_UP LEFT = TURN_DOWN_LEFT
-getGrownHead HEAD_UP RIGHT = TURN_DOWN_RIGHT
+growHead HEAD_UP RIGHT = TURN_DOWN_RIGHT
-getGrownHead HEAD_RIGHT RIGHT = HORIZONTAL
+growHead HEAD_RIGHT RIGHT = HORIZONTAL
-getGrownHead HEAD_RIGHT UP = TURN_UP_LEFT
+growHead HEAD_RIGHT UP = TURN_UP_LEFT
-getGrownHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT
+growHead HEAD_RIGHT DOWN = TURN_DOWN_LEFT
-getGrownHead HEAD_DOWN DOWN = VERTICAL
+growHead HEAD_DOWN DOWN = VERTICAL
-getGrownHead HEAD_DOWN RIGHT = TURN_UP_RIGHT
+growHead HEAD_DOWN RIGHT = TURN_UP_RIGHT
-getGrownHead HEAD_DOWN LEFT = TURN_UP_LEFT
+growHead HEAD_DOWN LEFT = TURN_UP_LEFT
-getGrownHead HEAD_LEFT LEFT = HORIZONTAL
+growHead HEAD_LEFT LEFT = HORIZONTAL
-getGrownHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT
+growHead HEAD_LEFT DOWN = TURN_DOWN_RIGHT
-getGrownHead HEAD_LEFT UP = TURN_UP_RIGHT
+growHead HEAD_LEFT UP = TURN_UP_RIGHT
-getGrownHead _ _ = error "Invalid getGrownHead arguments"
+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
+shrinkTail :: SnakeSegmentOrientation -> Direction -> SnakeSegmentOrientation
-getNewTail HEAD_UP UP = TAIL_UP
+shrinkTail HEAD_UP UP = TAIL_UP
-getNewTail HEAD_RIGHT RIGHT = TAIL_RIGHT
+shrinkTail HEAD_RIGHT RIGHT = TAIL_RIGHT
-getNewTail HEAD_DOWN DOWN = TAIL_DOWN
+shrinkTail HEAD_DOWN DOWN = TAIL_DOWN
-getNewTail HEAD_LEFT LEFT = TAIL_LEFT
+shrinkTail HEAD_LEFT LEFT = TAIL_LEFT
-getNewTail TURN_UP_RIGHT LEFT = TAIL_UP
+shrinkTail TURN_UP_RIGHT LEFT = TAIL_UP
-getNewTail TURN_UP_RIGHT DOWN = TAIL_RIGHT
+shrinkTail TURN_UP_RIGHT DOWN = TAIL_RIGHT
-getNewTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN
+shrinkTail TURN_DOWN_RIGHT LEFT = TAIL_DOWN
-getNewTail TURN_DOWN_RIGHT UP = TAIL_RIGHT
+shrinkTail TURN_DOWN_RIGHT UP = TAIL_RIGHT
-getNewTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN
+shrinkTail TURN_DOWN_LEFT RIGHT = TAIL_DOWN
-getNewTail TURN_DOWN_LEFT UP = TAIL_LEFT
+shrinkTail TURN_DOWN_LEFT UP = TAIL_LEFT
-getNewTail TURN_UP_LEFT RIGHT = TAIL_UP
+shrinkTail TURN_UP_LEFT RIGHT = TAIL_UP
-getNewTail TURN_UP_LEFT DOWN = TAIL_LEFT
+shrinkTail TURN_UP_LEFT DOWN = TAIL_LEFT
-getNewTail HORIZONTAL RIGHT = TAIL_RIGHT
+shrinkTail HORIZONTAL RIGHT = TAIL_RIGHT
-getNewTail HORIZONTAL LEFT = TAIL_LEFT
+shrinkTail HORIZONTAL LEFT = TAIL_LEFT
-getNewTail VERTICAL UP = TAIL_UP
+shrinkTail VERTICAL UP = TAIL_UP
-getNewTail VERTICAL DOWN = TAIL_DOWN
+shrinkTail VERTICAL DOWN = TAIL_DOWN
-getNewTail o d = error ("Invalid getNewTail arguments: " ++ show o ++ " " ++ show d)
+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))

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