hstzaar-0.9.2: src/Tests.hs

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