{- Quickcheck properties for board & AI code Pedro Vasconcelos, 2010, 2011 -} module Tests where import Board import AI.Tree import AI.Eval import AI.Minimax import qualified Data.Map as Map import qualified Data.Set as Set import List (delete, nub, sort) import Control.Monad (liftM) import Test.QuickCheck ------------------------------------------------------------------------ -- | QuickCheck generators ------------------------------------------------------------------------ -- generators for board elements instance Arbitrary Color where arbitrary = elements [White, Black] instance Arbitrary Kind where arbitrary = elements [Tzaar,Tzarra,Tott] -- default generator and counter-example shrinker for boards instance Arbitrary Board where arbitrary = sized genBoard {- shrink board = [board {active=you} | you<-shrinkHalf (active board)] ++ [board {inactive=other} | other<-shrinkHalf (inactive board)] -- 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]] -} -- generator for boards -- size argument is a bound for the total number of pieces -- always generates board with the 3 kinds for each player genBoard :: Int -> Gen Board genBoard size = do ws <- genStacks White n bs <- genStacks Black n ps <- genShuffle positions c <- arbitrary m <- choose (1, n) let whites = zip (take n ps) ws let blacks = zip (drop n ps) bs let pmap = Map.fromList (whites++blacks) return Board { active = c , move = m , pieces = pmap , activeCounts = countStacks c pmap , inactiveCounts = countStacks (invert c) pmap , activeHeights = sumHeights c pmap , inactiveHeights= sumHeights (invert c) pmap } where n = 3 `max` (size`div`2) `min` 30 -- between 3 and 30 stacks -- generate piece stacks genStacks :: Color -> Int -> Gen [Piece] genStacks c n = do ps <- liftM ([Tzaar,Tzarra,Tott]++) (genShuffle pieces) hs <- sequence [choose (1,maxHeight) | _<-[1..n]] return (zip3 (repeat c) ps hs) where pieces = replicate 5 Tzaar ++ replicate 8 Tzarra ++ replicate 14 Tott maxHeight = 5 -- generate random permutations of a list genShuffle :: Eq a => [a] -> Gen [a] genShuffle [] = return [] genShuffle xs = do x <- elements xs xs'<- genShuffle (delete x xs) return (x:xs') --------------------------------------------------------------------------- -- Quickcheck properties --------------------------------------------------------------------------- -- properties of the game mechanics -- a capture reduces the number of pieces by one prop_capture_moves :: Board -> Bool prop_capture_moves b = and [countPieces b == 1+countPieces b' | m <- captureMoves b, let b' = applyMove m b] -- a stacking reduces the number of pieces by one prop_stacking_moves1 :: Board -> Bool prop_stacking_moves1 b = and [countPieces b == 1+ countPieces b' | m <- stackingMoves b, let b' = applyMove m b] -- stacking mantains the sum of pieces heights of the active player prop_stacking_moves2 :: Board -> Bool prop_stacking_moves2 b = and [ heights (pieces b) == heights (pieces b') | m <- stackingMoves b, let b'=applyMove m b] where c = active b -- the current player heights ps = sum [h | (c',_,h)<-Map.elems ps, c'==c] -- stacking does not modify opponents pieces prop_stacking_moves3 :: Board -> Bool prop_stacking_moves3 b = and [ Map.filter (\p->color p==c') (pieces b') == Map.filter (\p->color p==c') (pieces b) | m <- stackingMoves b, let b'=applyMove m b] where c = active b -- the current player c'= invert c -- the other player prop_swap_swap :: Board -> Bool prop_swap_swap b = swapBoard (swapBoard b) == b prop_active_counts :: Board -> Bool prop_active_counts b = and [activeCounts b' == countStacks (active b') (pieces b') | m<-nextMoves b, let b'=applyMove m b] prop_inactive_counts :: Board -> Bool prop_inactive_counts b = and [inactiveCounts b' == countStacks (inactive b') (pieces b') | m<-nextMoves b, let b'=applyMove m b] prop_active_heights :: Board -> Bool prop_active_heights b = and [activeHeights b' == sumHeights (active b') (pieces b') | m<-nextMoves b, let b'=applyMove m b] prop_inactive_heights :: Board -> Bool prop_inactive_heights b = and [inactiveHeights b' == sumHeights (inactive b') (pieces b') | m<-nextMoves b, let b'=applyMove m b] -- 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 = captureMoves b moves2 = concat [captureMoves (swapBoard (applyMove m b)) | m<-moves1] pos = Set.fromList [dest | Capture _ dest<-(moves1++moves2)] pos'= Map.keysSet (zoneOfControl (active b) (pieces b)) --------------------------------------------------------------------------- -- properties of the AI code --------------------------------------------------------------------------- -- | a trace is a sequence of game positions newtype Trace = Trace { unTrace :: [Board] } deriving Show instance Arbitrary Trace where arbitrary = do b <- arbitrary liftM Trace (genTrace b) -- | generate a sequence random board resulting -- from valid moves from a starting board genTrace :: Board -> Gen [Board] genTrace b | null moves = return [b] | otherwise = do m <- elements moves let b' = applyMove m b bs <- genTrace b' return (b:bs) where moves = nextMoves b -- | players must alternate in a trace prop_trace_alternating (Trace bs) = let players = map active bs in and $ zipWith (/=) players (tail players) -- | both players have 3 kinds of pieces until the end of the game prop_trace_ending (Trace bs) = let b' = last bs bs'= init bs in all threekinds bs' && (lostone b' || null (nextMoves b')) where threekinds b = all (>0) (countStacks (active b) (pieces b) ++ countStacks (inactive b) (pieces b)) lostone b = any (==0) (countStacks (active b) (pieces b)) -- | upper and lower bounds for the evaluation function prop_value_bounds :: Eval -> Trace -> Bool prop_value_bounds eval (Trace bs) = let vs = map eval bs in all (\v -> abs v<=infinity) vs -- correcteness of alpha-beta pruning against plain minimax -- parameters: number of pieces, pruning depth prop_alpha_beta :: Int -> Board -> Bool prop_alpha_beta d b = let bt = pruneDepth d $ mapTree eval1 $ boardTree b in negamax_ab (-infinity) infinity bt == negamax bt -- correctness of alpha-beta minimax extended with principal variation -- parameters: number of pieces, pruning depth prop_alpha_beta_pv :: Int -> Board -> Bool prop_alpha_beta_pv d b = let bt = pruneDepth d $ mapTree eval1 $ boardTree b (v,ms)= negamaxPV bt n = length ms b' = foldl (flip applyMove) b ms v' = eval1 b' in (-1)^n * v' == v {- -- end game positions give plus/minus infinity scores prop_inactive_lost :: Eval -> Board -> Property prop_inactive_lost f b = not (active_lost b) && inactive_lost b ==> f b == infinity prop_active_lost :: Eval -> Board -> Property prop_active_lost f b = not (inactive_lost b) && active_lost b ==> f b == (-infinity) treeMove :: Eq m => GameTree s m -> m -> GameTree s m treeMove (GameTree _ branches) m = head [t | (m',t)<-branches, m'==m] mkTree :: Int -> Eval -> Board -> GameTree Int Move mkTree depth eval board = pruneDepth depth $ mapTree eval $ boardTree board wellformedTree :: GameTree Board Move -> Bool wellformedTree (GameTree b branches) = and [player b /= player b' && wellformedTree t | (m,t@(GameTree b' _)) <- branches] -- 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 (captureMoves 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_stacking_moves3", quickCheck prop_stacking_moves3) , ("prop_swap_swap", quickCheck prop_swap_swap) , ("prop_active_counts", quickCheck prop_active_counts) , ("prop_inactive_counts", quickCheck prop_inactive_counts) , ("prop_active_heights", quickCheck prop_active_heights) , ("prop_inactive_heights", quickCheck prop_inactive_heights) , ("prop_zoc_correct", quickCheck prop_zoc_correct) , ("prop_trace_alternating", quickCheck prop_trace_alternating) , ("prop_trace_ending", quickCheck prop_trace_ending) , ("prop_value_bounds", quickCheck (prop_value_bounds eval1)) , ("prop_alpha_beta_pv 3", quickCheck (prop_alpha_beta_pv 3)) , ("prop_alpha_beta_pv 5", quickCheck (prop_alpha_beta_pv 5)) , ("prop_alpha_beta_pv 6", quickCheck (prop_alpha_beta_pv 6)) ] quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n})