Tests
This commit is contained in:
parent
b2b81b444c
commit
1dd23d6e62
4 changed files with 188 additions and 41 deletions
131
test/Main.hs
131
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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue