HongTest.hs

-- | 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