Tests
This commit is contained in:
parent
b2b81b444c
commit
1dd23d6e62
4 changed files with 188 additions and 41 deletions
|
|
@ -24,7 +24,7 @@ main = do
|
|||
destroyWindow window
|
||||
|
||||
targetFps :: Word32
|
||||
targetFps = 2
|
||||
targetFps = 5
|
||||
|
||||
targetFrameMs :: Word32
|
||||
targetFrameMs = 1000 `div` targetFps
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
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