Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
71 lines (59 sloc) 2.71 KB
-- | This module tests the Hong game, all tests are pure (no side effects).
-- The reason why the tests take some seconds to run is simply that
-- we must have a high sampling rate in order to ensure to logic is
-- correct, and thus we also must look at many samples which takes time.
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module HongTest (specs) where
import Test.Hspec
import Test.Hspec.HUnit ()
import Fal
import GameState
import UserControl
import HongConstants
run :: State -> [State]
run s0 = runBehavior (pong' s0 uc) (repeat Nothing, [0, 0.002..])
ever, never :: (State -> Bool) -> [State] -> Bool
ever f ss = any f $ take 20000 ss
never f = not . ever f
outside :: State -> Bool
outside s = abs (xPosition s) > (planeHalfWidth + epsilon)
|| abs (yPosition s) > (planeHalfHeight + epsilon)
alwaysInside :: [State] -> Bool
alwaysInside = never outside
specs :: Spec
specs = describe "Hong" $ do
it "tests the test framework" True
describe "bounces on walls" $ do
let ss = run startState{ xVelocity = 0 }
it "always have ball inside" $ alwaysInside ss
it "bounces roof" $ ever (\s -> yVelocity s < 0) ss
it "bounces floor" $
ever (\s -> yPosition s < 0 && yVelocity s > 0) ss
describe "bounces on paddles" $ do
let ss = run startState{ yVelocity = 0 }
it "keeps bouncing" $ alwaysInside ss
it "bounces on right paddle" $ ever (\s -> xVelocity s < 0) ss
it "bounces on left paddle" $
ever (\s -> xPosition s < 0 && xVelocity s > 0) ss
describe "avoids bounces when paddle not present" $ do
let s0 = startState { yVelocity = 0
, leftPaddle = 1000
, rightPaddle = (-1000) }
let ss = run s0{ xVelocity = 1 }
in it "no bounce on right paddle" $
ever (\s -> xPosition s > 2*planeHalfWidth) ss
let ss = run s0{ xVelocity = (-1) }
in it "no bounce on left paddle" $
ever (\s -> xPosition s < (-2)*planeHalfWidth) ss
describe "paddles move correctly" $ do
let ts = [0.01..]
ucl = lift1 (signum . (10-)) time
ucr = lift1 (negate . signum . (10-)) time
uc = lift2 UserControl ucl ucr
ss = runBehavior (pong' startState uc) (repeat Nothing, ts)
maxHeight = highestPaddlePoint + epsilon
it "can move left paddle" $ ever (\s -> leftPaddle s > planeHalfHeight/2) ss
it "can move right paddle" $ ever (\s -> rightPaddle s > planeHalfHeight/2) ss
it "has bounded left paddle" $ never (\s -> abs (leftPaddle s) > maxHeight) ss
it "has bounded right paddle" $ never (\s -> abs (rightPaddle s) > maxHeight) ss