{- 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 Data.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 = 0 , moves = [] , 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 ms = return [b] | otherwise = do m <- elements ms bs <- genTrace (applyMove m b) return (b:bs) where ms = 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 :: StaticEval -> Trace -> Bool --prop_value_bounds f (Trace bs) -- = let vs = map f 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_alpha_beta (minBound+1) maxBound 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 PV v ms = undefined -- 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_move_count", quickCheck prop_move_count) , ("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})