hstzaar-0.5: src/Tests.hs

{-
  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.IntMap as IntMap
import qualified Data.IntSet as IntSet
import List (delete, nub, sort)


---------------------------------------------------------------------------
-- Quickcheck properties 
---------------------------------------------------------------------------

-- a capture reduces the number of pieces by one
prop_capture_moves :: Board -> Bool
prop_capture_moves b
    = and [1+boardSize b' == boardSize b |
           m<-nextCaptureMoves b, let b' = applyMove b m]

-- a stacking reduces the number of pieces by one
prop_stacking_moves1 :: Board -> Bool
prop_stacking_moves1 b
    = and [1+boardSize b' == boardSize b |
           m<-nextStackingMoves b, let b' = applyMove b m]

-- stacking mantains the sum of pieces heights of the active player
-- and does not change the pieces of the other player
prop_stacking_moves2 :: Board -> Bool
prop_stacking_moves2 b
    = and [ heights (active b') == heights (active b) && inactive b' == inactive b | 
             m <- nextStackingMoves b, let b'=applyMove b m]
    where heights b = sum [h | (_,h)<-IntMap.elems b]


---------------------------------------------------------------------------
-- some properties of the AI code
---------------------------------------------------------------------------

{-
-- static evaluation respects the zero-sum property
prop_zero_sum :: Board -> Property
prop_zero_sum b
    = admissible b ==> eval b - eval (swapBoard b) == 0
-}

-- upper and lower bounds for the evaluation function
prop_value_bounds :: Board -> Property
prop_value_bounds b
    = not (active_lost b) && not (inactive_lost b) ==> abs value < infinity
    where value = static_eval b


-- end game positions give plus/minus infinityinity scores
prop_inactive_lost :: Board -> Property
prop_inactive_lost b
    = not (active_lost b) && inactive_lost b ==> 
      static_eval b == infinity 

prop_active_lost :: Board -> Property
prop_active_lost b
    = not (inactive_lost b) && active_lost b ==> 
      static_eval b == (-infinity)



-- 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 $ \b ->
      not (active_lost b) ==>
          let bt = mkTree depth breadth b
          in minimax_ab (-infinity) infinity bt == minimax bt
    

-- extended alpha-beta minimax computes the first move of the principal variation
-- 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 $ \b ->
      not (active_lost b)  ==> 
          let bt = mkTree depth breadth b
              (m,v)= minimaxMove_ab (-infinity) infinity bt
              bt' = treeMove m bt
          in  minimax bt' == -v


mkTree :: Int -> Int -> Board -> GameTree Int Turn
mkTree depth breadth board = pruneDepth depth $ 
                             pruneBreadth breadth $ 
                             lowFirst $
                             mapTree static_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_correct :: Board -> Bool
prop_zoc_correct b = pos == pos'
    where
      moves1 = nextCaptureMoves b
      moves2 = concat [nextCaptureMoves (applyMove b m) | m<-moves1]
      pos = IntSet.fromList (map snd moves1 ++ map snd moves2)
      pos'= IntMap.keysSet (zoneOfControl b)


-- 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 = null (nextCaptureMoves b) || pieceTypes (active b)/= 3
inactive_lost = active_lost . swapBoard


-- 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_zero_sum", quickCheck prop_zero_sum)
            , ("prop_value_bounds", quickCheck prop_value_bounds)
            , ("prop_inactive_lost", quickCheck prop_inactive_lost)
            , ("prop_active_lost", quickCheck prop_active_lost)
            , ("prop_zoc_correct", quickCheck prop_zoc_correct)
            --, ("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))
            ]



quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n})