{- 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)) ]