hstzaar-0.9.4: 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.HashMap.Strict as HashMap
import qualified Data.Set as Set
import qualified Data.Vector.Unboxed as Vec
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 = HashMap.fromList (whites++blacks)
       return Board { active = c
                    , move = 0
                    -- , moves = []
                    , pieces = pmap
                    , activeCounts = Vec.fromList $ countStacks c pmap
                    , inactiveCounts = Vec.fromList $ countStacks (invert c) pmap
                    , activeHeights = Vec.fromList $ sumHeights c pmap
                    , inactiveHeights= Vec.fromList $ 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 (zipWith3 Piece (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 | (Piece c' _ h)<-HashMap.elems ps, c'==c]

-- stacking does not modify opponents pieces
prop_stacking_moves3 :: Board -> Bool
prop_stacking_moves3 b
    = and [ HashMap.filter (\p->color p==c') (pieces b') ==
            HashMap.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 = swapPlayer (swapPlayer b) == b

prop_active_counts :: Board -> Bool
prop_active_counts b
  = and [activeCounts b' ==  Vec.fromList (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' ==  Vec.fromList (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' ==  Vec.fromList (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' ==  Vec.fromList (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 (swapPlayer (applyMove m b)) | m<-moves1]
      pos = Set.fromList [dest | Capture _ dest<-(moves1++moves2)]
      pos'= Set.fromList $ HashMap.keys $ 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})