hstzaar-0.4: src/Tests.hs
{-
Quickcheck properties for board & AI code
Pedro Vasconcelos, 2010
-}
module Tests (run_tests) where
import Board
import AI.Minimax
import AI.Utils
import AI.Eval
import Test.QuickCheck
import qualified Data.Map as Map
import qualified Data.Set as Set
import List (delete, nub, sort)
-- generators for board elements
instance Arbitrary Type where
arbitrary = elements [Tzaar,Tzarra,Tott]
instance Arbitrary Position where
arbitrary = elements positions
-- a new type isomorphic to boards for testing purposes
newtype TestBoard = TestBoard Board deriving Show
-- default generator and counter-exemple shrinker for boards
instance Arbitrary TestBoard where
arbitrary = sized genBoard
shrink (TestBoard (w,b))
= [TestBoard (w',b) | w'<-shrinkHalf w] ++
[TestBoard (w,b') | b'<-shrinkHalf b]
-- helper function to shrink half-boards
-- first try to remove pieces, then reduce heights
shrinkHalf :: HalfBoard -> [HalfBoard]
shrinkHalf b = [Map.delete p b | p<-Map.keys b] ++
[Map.insert p (t,h') b |
(p,(t,h))<-Map.assocs b, h'<-[1..h-1]]
-- a generator for boards
-- size argument is a bound for the total number of pieces
genBoard :: Int -> Gen TestBoard
genBoard n = do ws <- genPieces n'
bs <- genPieces n'
positions' <- genShuffle positions
let whites = zip (take n' positions') ws
let blacks = zip (drop n' positions') bs
return $ TestBoard (Map.fromList whites,
Map.fromList blacks)
where n' = (min 60 n)`div`2
genPieces :: Int -> Gen [(Type,Int)]
genPieces n = do pieces <- genShuffle allpieces
k <- choose (0,n)
genStacks k (take n pieces)
where allpieces = [(t,1) | t<-replicate 6 Tzaar ++
replicate 9 Tzarra ++
replicate 15 Tott]
-- generate stacks from single pieces
genStacks 0 xs = return xs
genStacks _ [] = return []
genStacks _ [x]= return [x]
genStacks (n+1) xs = do p1@(t1,h1) <- elements xs
let xs' = delete p1 xs
p2@(t2,h2) <- elements xs'
genStacks n ((t1,h1+h2) : delete p2 xs')
-- auxiliary function to shuffle a list
genShuffle :: Eq a => [a] -> Gen [a]
genShuffle [] = return []
genShuffle xs = do x <- elements xs
xs'<- genShuffle (delete x xs)
return (x:xs')
quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n})
---------------------------------------------------------------------------
-- Quickcheck properties
---------------------------------------------------------------------------
-- a capture reduces the number of pieces by one
prop_capture_moves :: TestBoard -> Bool
prop_capture_moves (TestBoard b)
= and [1+bdsize b' == bdsize b |
m<-nextCaptureMoves b, let b' = applyMove b m]
-- a stacking reduces the number of pieces by one
prop_stacking_moves1 :: TestBoard -> Bool
prop_stacking_moves1 (TestBoard b)
= and [1+bdsize b' == bdsize b |
m<-nextStackingMoves b, let b' = applyMove b m]
-- a stacking mantains the sum of pieces heights
prop_stacking_moves2 :: TestBoard -> Bool
prop_stacking_moves2 (TestBoard b)
= and [ heights (fst b') == heights (fst b) &&
heights (snd b') == heights (snd b) |
m <- nextStackingMoves b, let b'=applyMove b m]
where heights b = sum [h | (_,h)<-Map.elems b]
---------------------------------------------------------------------------
-- some properties of the AI code
---------------------------------------------------------------------------
-- static evaluation respects the zero-sum property
prop_zero_sum :: Bool -> TestBoard -> Property
prop_zero_sum who (TestBoard b)
= admissible b ==> eval (who,b) - eval (not who, swapBoard b) == 0
-- upper and lower bounds for the evaluation function
prop_value_bounds :: TestBoard -> Property
prop_value_bounds (TestBoard b)
= not (white_lost b) && not (black_lost b) ==> score > -inf && score < inf
where score = value b
-- end game positions give plus/minus infinity scores
prop_black_lost :: TestBoard -> Property
prop_black_lost (TestBoard b)
= not (white_lost b) && black_lost b ==> (value b==inf)
prop_white_lost :: TestBoard -> Property
prop_white_lost (TestBoard b)
= not (black_lost b) && white_lost b ==> (value b == (-inf))
-- alpha-beta pruning computes the minimax value
-- parameters: number of pieces, pruning depth and breadth
prop_alpha_beta :: Int -> Int -> Int -> Property
prop_alpha_beta npieces depth breadth
= forAllShrink (resize npieces arbitrary) shrink $ \(TestBoard b) ->
not (white_lost b) ==>
let bt = mkTree depth breadth b
in minimax_ab (-inf) inf bt == minimax bt
-- the move computed by extended alpha-beta pruning is principal
-- parameters: number of pieces, pruning depth and breadth
prop_alpha_beta_move :: Int -> Int -> Int -> Property
prop_alpha_beta_move npieces depth breadth
= forAllShrink (resize npieces arbitrary) shrink $ \(TestBoard b) ->
not (white_lost b) ==>
let bt = mkTree depth breadth b
(m,v)= minimaxMove_ab (-inf) inf bt
bt' = treeMove m bt
in minimax bt' == -v
mkTree :: Int -> Int -> Board -> GameTree Int Turn
mkTree depth breadth board = prunedepth depth $
prunebreadth_asc breadth $
mapTree eval $
boardTree board
treeMove :: Eq m => m -> GameTree s m -> GameTree s m
treeMove m (GameTree _ branches) = 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_correct1 :: TestBoard -> Bool
prop_zoc_correct1 (TestBoard b) = pos == pos'
where
moves1 = nextCaptureMoves b
moves2 = concat [nextCaptureMoves (applyMove b m) | m<-moves1]
pos = Set.fromList (map snd moves1 ++ map snd moves2)
pos'= Map.keysSet (zoneOfControl (>=) b)
prop_zoc_correct2 :: TestBoard -> Bool
prop_zoc_correct2 (TestBoard b)
= zoc_gt `Map.isSubmapOf` zoc_geq
where zoc_geq = zoneOfControl (>=) b
zoc_gt = zoneOfControl (>) b
-- helper functions to filter boards, etc.
-- admissible boards: at most one loser
admissible, white_lost, black_lost :: Board -> Bool
admissible b = not (white_lost b && black_lost b)
white_lost b = null (nextCaptureMoves b) || pieceTypes (fst b)/= 3
black_lost = white_lost . swapBoard
-- number of piece types in a half-board
pieceTypes :: HalfBoard -> Int
pieceTypes b = length $ nub $ map fst $ Map.elems b
-- board size (number of pieces)
bdsize :: Board -> Int
bdsize (w,b) = Map.size w + Map.size 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_black_lost", quickCheck prop_black_lost)
, ("prop_white_lost", quickCheck prop_white_lost)
, ("prop_zoc_correct1", quickCheck prop_zoc_correct1)
, ("prop_zoc_correct2", quickCheck prop_zoc_correct2)
, ("prop_alpha_beta 10 4 5",
quickCheck (prop_alpha_beta 10 4 5))
, ("prop_alpha_beta 15 6 5",
quickCheck (prop_alpha_beta 15 6 5))
, ("prop_alpha_beta_move 10 4 5",
quickCheck (prop_alpha_beta_move 10 4 5))
, ("prop_alpha_beta_move 15 6 5",
quickCheck (prop_alpha_beta_move 15 6 5))
]