hstzaar-0.6: src/Tests.hs

{-
  Quickcheck properties for board & AI code
  Pedro Vasconcelos, 2010, 2011
-}
module Tests (run_tests) where
import Board 
import AI.Minimax
import AI.Utils
import AI.Eval
import Test.QuickCheck
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import List (delete, nub, sort)


---------------------------------------------------------------------------
-- Quickcheck properties 
---------------------------------------------------------------------------

-- a capture reduces the number of pieces by one
prop_capture_moves :: Board -> Bool
prop_capture_moves b
    = and [1+boardSize b' == boardSize b |
           m<-nextCaptureMoves b, let b' = applyMove b m]

-- a stacking reduces the number of pieces by one
prop_stacking_moves1 :: Board -> Bool
prop_stacking_moves1 b
    = and [1+boardSize b' == boardSize b |
           m<-nextStackingMoves b, let b' = applyMove b m]

-- stacking mantains the sum of pieces heights of the active player
-- and does not change the pieces of the other player
prop_stacking_moves2 :: Board -> Bool
prop_stacking_moves2 b
    = and [ heights (active b') == heights (active b) && inactive b' == inactive b | 
             m <- nextStackingMoves b, let b'=applyMove b m]
    where heights b = sum [h | (_,h)<-IntMap.elems b]


---------------------------------------------------------------------------
-- some properties of the AI code
---------------------------------------------------------------------------


-- upper and lower bounds for the evaluation function
prop_value_bounds :: Board -> Property
prop_value_bounds board
    = not (active_lost board) && not (inactive_lost board) ==> abs value < infinity
    where value = eval board


-- end game positions give plus/minus infinityinity scores
prop_inactive_lost :: Board -> Property
prop_inactive_lost b
    = not (active_lost b) && inactive_lost b ==> eval b == infinity 

prop_active_lost :: Board -> Property
prop_active_lost b
    = not (inactive_lost b) && active_lost b ==> eval b == (-infinity)


-- correcteness of alpha-beta pruning against plain minimax 
-- parameters: number of pieces, pruning depth 
prop_alpha_beta :: Int -> Int  -> Property
prop_alpha_beta npieces depth 
    = forAllShrink (resize npieces arbitrary) shrink $ \b ->
      admissible b ==>
          let bt = mkTree depth b
          in minimax_ab (-infinity) infinity bt == minimax bt
    

-- correctness of alpha-beta minimax extended with principal variation
-- parameters: number of pieces, pruning depth 
prop_alpha_beta_pv :: Int -> Int -> Property
prop_alpha_beta_pv npieces depth 
    | depth`mod`4 == 0
        = forAllShrink (resize npieces arbitrary) shrink $ \b ->
          admissible b  ==> 
          let bt = mkTree depth b
              (v,ms)= minimaxPV bt
              (GameTree v' _) = foldl treeMove bt ms
          in neg (length ms) v'==v
    where neg n x | n`mod`4==0 = x
                  | n`mod`4==2 = -x


mkTree :: Int -> Board -> GameTree Int Move
mkTree depth board = pruneDepth depth $ mapTree eval $ boardTree board


treeMove :: Eq m => GameTree s m -> m -> GameTree s m
treeMove (GameTree _ branches) m = head [t | (m',t)<-branches, m'==m]




 
-- correctness of the zone of control computation
-- the zone of control is the set of pieces
-- that can be captured in a turn (one or two moves)
prop_zoc_correct :: Board -> Bool
prop_zoc_correct b = pos == pos'
    where
      moves1 = nextCaptureMoves b
      moves2 = concat [nextCaptureMoves (applyMove b m) | m<-moves1]
      pos = IntSet.fromList [dest | Capture _ dest<-(moves1++moves2)]
      pos'= IntMap.keysSet (zoneOfControl b)


-- helper functions to filter boards, etc.
-- "admissible" boards: no winner yet
admissible :: Board -> Bool
admissible b = not (active_lost b) && not (inactive_lost b)

active_lost, inactive_lost :: Board -> Bool
active_lost b 
    = (move b==1 && null (nextCaptureMoves b)) || 
      any (==0) (countStacks $ active b)

inactive_lost b = any (==0) (countStacks $ inactive b)


-- number of piece types in a half-board
--pieceTypes :: HalfBoard -> Int
--pieceTypes b = length $ nub $ map fst $ IntMap.elems b


-- run all tests
run_tests :: IO ()
run_tests = mapM_ run_test all_tests
    where run_test (name, test) = putStrLn (">>> " ++ name) >> test

all_tests = [ ("prop_capture_moves", quickCheck prop_capture_moves)
            , ("prop_stacking_moves1", quickCheck prop_stacking_moves1)
            , ("prop_stacking_moves2", quickCheck prop_stacking_moves2)
            --, ("prop_zero_sum", quickCheck prop_zero_sum)
            , ("prop_value_bounds", quickCheck prop_value_bounds)
            , ("prop_inactive_lost", quickCheck prop_inactive_lost)
            , ("prop_active_lost", quickCheck prop_active_lost)
            , ("prop_zoc_correct", quickCheck prop_zoc_correct)
            --, ("prop_zoc_correct2", quickCheck prop_zoc_correct2)
            , ("prop_alpha_beta 10 4",
               quickCheck (prop_alpha_beta 10 4))
            , ("prop_alpha_beta 15 6",
               quickCheck (prop_alpha_beta 15 6))
            , ("prop_alpha_beta_pv 10 4",
               quickCheck (prop_alpha_beta_pv 10 4))
            , ("prop_alpha_beta_pv 15 6",
               quickCheck (prop_alpha_beta_pv 15 6))
            ]



quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n})