diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,89 @@ +HsTZAAR +------- + +HsTZAAR is a computer program to play TZAAR, a 2-player abstract strategy +game designed by Kris Burm and the last game in the GIPF project. +HsTZAAR is written in Haskell and allows for local play against a computer AI; +it also provides a good interface for programmers to implement diferent +AI strategies. + +This program was based on the htzaar implementation by Tom Hawkins. +In 2010, I started experimenting with classical AI techniques for TZAAR +and implemented them on-top of htzaar; since the later package is longer +updated, I decided to start HsTZAAR. + +The main improvements so far are: + + * a better GUI using gtk2hs for widgets and cairo for high-quality + 2D board rendering. + * a better AI using minimax and alpha-beta prunning; it now plays at + a challenging level (at least for a beginner like myself). + +Requirements +------------ + +HsTZAAR requires a resonably recent GHC compiler (version 6.10.x or newer) +plus the gtk2hs, cairo and glade libraries. It is developed in Ubuntu +GNU/Linux system, and should compile and run fine on other Linuxes. +I also verified that it compiles under Mac OS X (snow leopard) and should +probabily do under Windows as well (but this was not tested). + +Compilation +----------- + +Using the Haskell Cabal tool (fetches the package and any dependencies, +builds and installs): + + $ cabal install hstzaar + +Alternatively, you can do the build manually from the source tarball: + +$ tar xvzf hstzaar-x.y.tar.gz +$ cd hstzaar-x.y +$ runhaskell Setup.hs configure +$ runhaskell Setup.hs build +$ runhaskell Setup.hs install + +AI strategies +-------------- + +HsTZAAR implements a few AI strategies. + lame: selects a random valid move + greedy: selects the local best move by the static evaluation function + plyN: simple minimaxing to N-ply + dynN: greedy strategy for early game, then minimaxing N-ply for later game +All of the above will select a winning move or a move to prevent the +adversary from winning (if such moves are avaliable). + +Note that higher ply values can increase memory consumption dramatically +and do *not* necessarily play better! The default greedy strategy plays +well enough to challenge a beginner such as myself and run under 150Mb +resident space. + +Usage +----- + +Executing the binary starts the GUI interface for playing against an AI; +some extra options are controlled by command line arguments: + +hstzaar [OPTION..] [AI AI] where OPTIONS are + -s SEED --seed=SEED random number seed + -n N --matches=N number of matches (for AI tournaments) + -T --tests run QuickCheck tests + +Examples: + +1) Run a tournament between the greedy and ply2 strategies: + 10 matches (5 random boards, each strategy plays first white + then black, fixing the random seed for repeatebility): + + $ hstzaar -s0 -n10 greedy ply2 + +2) Run QuickCheck correctness tests (see source code for details on these): + + $ hstzaar --tests + + +Pedro Vasconcelos, 2010 +pbv@dcc.fc.up.pt + diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -1,4 +1,10 @@ +hstzaar 0.4 22/10/2010 +- zoneOfControl computation now properly accounts for interleaved captures +- improved some board and AI functions for speed/accurary +- added an AI vs. AI tournament batch mode +- added a test module with Quickcheck properties for board & AI code + hstzaar 0.3 21/08/2010 - improved the AI (new static evaluation function) - corrected duplicate undo/redo entry after game end diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -1,5 +1,5 @@ name: hstzaar -version: 0.3 +version: 0.4 category: Game @@ -25,17 +25,20 @@ data-files: data/hstzaar.glade extra-source-files: - RELEASE-NOTES + RELEASE-NOTES README executable hstzaar hs-source-dirs: src main-is: Main.hs - other-modules: GUI Board AI AI.Utils AI.Lame AI.Minimax + other-modules: GUI Board AI AI.Utils AI.Lame AI.Eval AI.Minimax Tournament Tests build-depends: base >= 4 && < 5, + haskell98, containers, gtk >=0.11, cairo >= 0.11, glade >= 0.11, - random >= 1.0.0 && < 1.1 + random >= 1.0.0 && < 1.1, + QuickCheck >= 2.1 + ghc-prof-options: -prof -auto-all diff --git a/src/AI.hs b/src/AI.hs --- a/src/AI.hs +++ b/src/AI.hs @@ -2,10 +2,14 @@ module AI (ai_players) where import Board - import AI.Lame import AI.Minimax + +-- all AI players; default AI is the first one (greedy) ai_players :: [AI] -ai_players = [dyn1, dyn2, ply2, ply3, ply4, greedy, lame] +ai_players = [greedy, lame] ++ + [plyN n | n<-[1,2,4,6]] ++ + [dynamic n | n<-[2,4,6]] + diff --git a/src/AI/Eval.hs b/src/AI/Eval.hs new file mode 100644 --- /dev/null +++ b/src/AI/Eval.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +-- Static evaluation functions for board positions +module AI.Eval( eval + , value + , zoneOfControl + , inf + ) where + +import Board +import qualified Data.Map as Map + + +-- Static evaluation function for a board position +-- boolean is True if white player's turn, False for black player's turn +eval :: (Bool,Board) -> Int +eval (True, b) = value b +eval (False,b) = value (swapBoard b) + + + +-- value of a board position for the white player +-- assuming the white player is next to move (active player) +value :: Board -> Int +value b@(white,black) + | minimum wtypes==0 || null wcaptures = -inf + | minimum btypes==0 || null bcaptures = inf + | otherwise = material + 8*positional + threats + where + -- piece counts for each player + wtypes = countPieces white + btypes = countPieces black + + -- capture moves for each player + wcaptures = nextCaptureMoves b + bcaptures = nextCaptureMoves (swapBoard b) + + -- the zones of control for each player + wzoc = zoneOfControl (>=) b + bzoc = zoneOfControl (>) (swapBoard b) + + -- piece types in each zone of control + wzoc_types = countPieces wzoc + bzoc_types = countPieces bzoc + + -- material score + material = sumHeights white - sumHeights black + + -- positional score + -- positional = sumHeights wzoc - sumHeights bzoc + positional = Map.size wzoc - Map.size bzoc + + -- immediate threats + threats | bt<=wt = penalty bt + | otherwise = - penalty wt + + -- immediately threatened pieces + wt = minimum [x-min 2 y | (x,y)<-zip wtypes bzoc_types] + bt = minimum [x-min 2 y | (x,y)<-zip btypes wzoc_types] + + penalty n | n<=2 = inf`div`2^(n+1) + | otherwise = 0 + + + +-- the maximum evaluation score +inf :: Int +inf = 2^10 + + +-- sum the heights of pieces (material value of a player) +-- specification: +-- sumHeights b = sum [h | (_,h)<-Map.elems b] +sumHeights :: HalfBoard -> Int +sumHeights b = sum 0 [h | (_,h)<-Map.elems b] + where sum :: Int -> [Int] -> Int + sum !s [] = s + sum !s (!x:xs) = sum (s+x) xs + + + + +-- Estimate the "zone of control" of the white player +-- i.e. black pieces that can be captured in one or two moves +zoneOfControl :: (Int->Int->Bool) -> Board -> HalfBoard +zoneOfControl cmp board@(white,black) + = Map.filterWithKey forPiece1 black + where + -- white pieces that can make at least one capture + captures = Map.filterWithKey forPiece2 white + + forPiece1, forPiece2 :: Position -> Piece -> Bool + forPiece1 p (_, i) = or $ map (downLine0 i) $ sixLines p + forPiece2 p (_, h) = or $ map (downLine2 h) $ sixLines p + + downLine0, downLine1, downLine2 :: Int -> [Position] -> Bool + + downLine0 i [] = False + downLine0 i (p:ps) + = case atPosition board p of + Nothing -> downLine0 i ps + Just (True, (_, h)) -> + h`cmp`i || (p`Map.member`captures && downLine1 i ps) + Just (False, (_, j)) -> + or $ map (downLine1 (max i j)) $ sixLines p + + downLine1 i [] = False + downLine1 i (p:ps) + = case atPosition board p of + Nothing -> downLine1 i ps + Just (True, (_, h)) -> h`cmp`i + _ -> False + + downLine2 h [] = False + downLine2 h (p:ps) + = case atPosition board p of + Nothing -> downLine2 h ps + Just (False, (_, i)) -> h`cmp`i + _ -> False + + + diff --git a/src/AI/Lame.hs b/src/AI/Lame.hs --- a/src/AI/Lame.hs +++ b/src/AI/Lame.hs @@ -10,7 +10,10 @@ lame = AI { name = "lame" , description = "Randomly selects the next valid turn." - , strategy = winOrPreventLoss lameStrategy + , strategy = (ifPieces (==60) + lameStrategy0 + (winOrPreventLoss lameStrategy) + ) } -- | The lame strategy picks a valid turn at random. If a two-move turn is available, it picks one. (wow, pretty smart!) @@ -22,3 +25,11 @@ turns = if null goodTurns then allTurns else goodTurns (i, g') = randomR (0, length turns - 1) g + +-- starting move +lameStrategy0 :: Strategy +lameStrategy0 (GameTree _ branches) g = (turns !! i, g') + where + allTurns = fst $ unzip branches + turns = [ (m1, Nothing) | (m1, Nothing) <- allTurns ] + (i, g') = randomR (0, length turns - 1) g diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs --- a/src/AI/Minimax.hs +++ b/src/AI/Minimax.hs @@ -1,10 +1,17 @@ - -module AI.Minimax(greedy, ply2,ply3,ply4, dyn1, dyn2) where +module AI.Minimax( greedy + , plyN + , dynamic + , minimax + , minimax_ab + , minimaxMove + , minimaxMove_ab + , prunedepth + , prunebreadth_asc + ) where import Data.List (sort, sortBy, maximumBy, minimumBy, nub, nubBy) -import qualified Data.Map as Map -import Data.Map (Map) import AI.Utils +import AI.Eval import Board import Debug.Trace @@ -14,12 +21,9 @@ greedy :: AI greedy = AI { name = "greedy" , description = "Maximize the static evaluation function" - , strategy = (ifPieces (==60) - (firstTurn greedyStrategy) - (ifPieces (>48) - (onlyCaptureStack greedyStrategy) - (narrowDoubleCaptures greedyStrategy) - ) + , strategy = (ifPieces (==60) + greedyStrategy + (winOrPreventLoss (singleCaptures greedyStrategy)) ) } @@ -27,97 +31,58 @@ greedyStrategy :: Strategy greedyStrategy (GameTree _ branches) rndgen - = trace ("Greedy score: " ++ show bestscore) (bestmove, rndgen) + = trace ("[greedy score: " ++ show bestscore ++ "]") (bestmove, rndgen) where - choices = [(m, eval (root t)) | (m,t)<-branches] - (bestmove,bestscore) = maximumBy (\x y -> compare (snd x) (snd y)) choices - root (GameTree x _) = x + choices = [(m, score t) | (m,t)<-branches] + (bestmove,bestscore) = maximumBy cmp choices + cmp (_,x) (_,y) = compare x y + score (GameTree _ []) = inf -- opponent loses + score (GameTree b _) = -eval b -- valued by the opponent --- straight minimaxing strategies with increasing depth -ply2 :: AI -ply2 = AI { name = "ply2" - , description = "Minimax with depth 2" - , strategy = (ifPieces (==60) - (firstTurn $ minimaxStrategy 2 3) - (narrowDoubleCaptures $ minimaxStrategy 2 3) - ) - } - -ply3 :: AI -ply3 = AI { name = "ply3" - , description = "Minimax with depth 3" - , strategy = (ifPieces (==60) - (firstTurn $ minimaxStrategy 3 3) - (narrowDoubleCaptures $ minimaxStrategy 3 3) - ) - } - -ply4 :: AI -ply4 = AI { name = "ply4" - , description = "Minimax with depth 4" - , strategy = (ifPieces (==60) - (firstTurn $ minimaxStrategy 4 3) - (narrowDoubleCaptures $ minimaxStrategy 4 3) - ) - } - --- dynamic strategies: --- increase the maximax depth and breadth towards the end game -dyn1 :: AI -dyn1 = AI { name = "dyn1" - , description = "Minimax with dynamic depth 1-4" - , strategy = (ifPieces (==60) - (firstTurn greedyStrategy) - (ifPieces (>48) - (onlyCaptureStack greedyStrategy) - (narrowDoubleCaptures $ - ifPieces (>28) - (minimaxStrategy 2 3) - (ifPieces (>20) - (minimaxStrategy 3 4) - (minimaxStrategy 4 6) - ) - ) - ) - ) - } - - -dyn2 :: AI -dyn2 = AI { name = "dyn2" - , description = "Minimax with dynamic depth 2-6" - , strategy = (ifPieces (==60) - (firstTurn greedyStrategy) - (ifPieces (>48) - (onlyCaptureStack $ minimaxStrategy 2 3) - (narrowDoubleCaptures $ - ifPieces (>28) - (minimaxStrategy 3 3) - (ifPieces (>20) - (minimaxStrategy 4 4) - (minimaxStrategy 6 6) - ) - ) - ) - ) - } - +-- straight minimaxing strategies with fixed depth +plyN :: Int -> AI +plyN n = AI { name = "ply" ++ show n + , description = "Minimax with depth " ++ show n + , strategy = (ifPieces (==60) + greedyStrategy + (winOrPreventLoss + (singleCaptures + (minimaxStrategy n 5)))) + } + +-- dynamic strategy +-- use greedy algorithm for opening then switching to maximaxing +dynamic :: Int -> AI +dynamic n = AI { name = "dyn" ++ show n + , description = "Minimax with dynamic depth " ++ show n + , strategy = (ifPieces (==60) + greedyStrategy + (winOrPreventLoss + (singleCaptures + (ifPieces (>40) + greedyStrategy + (minimaxStrategy n 5) + ) + ) + ) + ) + } -- Minimaxing strategy to ply depth `n' and breadth `m' --- using alpha-beta prunning +-- FIXME: for some reason alpha-beta prunning gives +-- worst results than plain minimaxing against the greedy strategy minimaxStrategy :: Int -> Int -> Strategy +minimaxStrategy n m (GameTree _ []) rndgen = error "minimaxStrategy: empty tree" minimaxStrategy n m g rndgen - = trace ("Minimax score: " ++ show bestscore) (bestmove, rndgen) - where (bestmove,bestscore) = minimaxMove_ab undefined (-inf) inf g' - g' = prunebreadth m $ -- ^ cut to breadth `m' - highfirst $ -- ^ order moves using static evaluation - mapTree eval $ -- ^ apply evaluation function - prunedepth n g -- ^ prune to depth `n' - + = trace ("[minimax score: "++ show bestscore ++"]") (bestmove, rndgen) + where (bestmove,bestscore) = minimaxMove g' -- minimaxMove_ab (-inf) inf g' + g' = prunebreadth_asc m $ -- ^ cut to breadth `m' + prunedepth n $ -- ^ prune to depth `n' + mapTree eval g -- ^ apply evaluation function -- Naive minimax algorithm (not used) @@ -128,8 +93,9 @@ -- auxiliary function that returns the best first move minimaxMove :: (Num a, Ord a) => GameTree a m -> (m,a) -minimaxMove (GameTree _ branches) = (m, -x) - where (m,x) = minimumBy (\x y ->compare (snd x) (snd y)) [(m,minimax t) | (m,t)<-branches] +minimaxMove (GameTree _ branches) = (m,x) + where (m,x) = maximumBy cmp [(m, -minimax t) | (m,t)<-branches] + cmp (_, x) (_, y) = compare x y @@ -144,157 +110,29 @@ -- This variant also returns the best initial move -minimaxMove_ab :: (Num a, Ord a) => m -> a -> a -> GameTree a m -> (m,a) -minimaxMove_ab m0 a b (GameTree x []) = (m0, a`max`x`min`b) -minimaxMove_ab m0 a b (GameTree _ branches) = cmx m0 a b branches +minimaxMove_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> (m,a) +minimaxMove_ab a b (GameTree _ []) = error "minimaxMove_ab: empty tree" +minimaxMove_ab a b (GameTree _ branches@((m,_):_)) = cmx m a b branches where cmx m a b [] = (m,a) cmx m a b ((m',t):branches) | a'>=b = (m',b) | otherwise = cmx m' a' b branches where a' = - minimax_ab (-b) (-a) t - --- Static evaluation function for a board position --- boolean indicates if active player is conducting the analysis -eval :: (Bool,Board) -> Int -eval (True, b) = value b -eval (False,b) = - value (swapBoard b) --- value of a board position for the active player -value :: Board -> Int -value b@(active,other) - | minimum pieces ==0 || null captures = -inf - | minimum pieces'==0 || null captures' = inf - | otherwise = material + positional + threats - where - -- piece counts for each player - pieces = counts active - pieces'= counts other - captures = nextCaptureMoves b - captures'= nextCaptureMoves (swapBoard b) - - -- the zones of control for each player - -- active player has advantage for equal height - zoc = zoneOfControl (>=) b - zoc'= zoneOfControl (>) (swapBoard b) - - -- capture counts by piece type - nzoc = counts zoc - nzoc'= counts zoc' - - -- material score - material = sumHeights active - sumHeights other - - -- positional score - positional = sumHeights zoc - sumHeights zoc' - - -- scores for immediate threats - threats = penalty p - penalty q - - p = minimum [x-min 2 y | (x,y)<-zip pieces' nzoc] - q = minimum [x-min 2 y | (x,y)<-zip pieces nzoc'] - - penalty n | n<=2 = inf`div`(2^(1+n)) - | otherwise = 0 - - - - --- a higher value than legitimate evaluation score -inf :: Int -inf = 2^10 - - --- count the number of pieces of each type --- results ordered by piece types -counts :: HalfBoard -> [Int] -counts b = Map.elems $ Map.fold (\(t,_)-> Map.adjust (+1) t) zeroPieces b - --- finite map assigning 0 to each piece type --- lifted to top-level to allow sharing across multiple calls -zeroPieces :: Map Type Int -zeroPieces = Map.fromList [(Tzaar,0),(Tzarra,0),(Tott,0)] - --- sum the heights of pieces (material value of a player) -sumHeights :: HalfBoard -> Int -sumHeights b = sum [h | (_,h)<-Map.elems b] - - - --- Estimate the "zone of control" of the active player --- i.e. the opponent's pieces reachable in one or two captures -zoneOfControl :: (Int->Int->Bool) -> Board -> HalfBoard -zoneOfControl cmp board@(_,other) - = Map.filterWithKey forPiece other - where - forPiece :: Position -> Piece -> Bool - forPiece p (_, i) = or $ map (downLine i) $ sixLines p - where - downLine, downLine' :: Int -> [Position] -> Bool - - downLine i [] = False - downLine i (p:ps) - = case atPosition board p of - Nothing -> downLine i ps - Just (True, (_, h)) -> h`cmp`i - Just (False, (_, j)) -> - or $ map (downLine' (max i j)) $ sixLines p - - downLine' i [] = False - downLine' i (p:ps) - = case atPosition board p of - Nothing -> downLine' i ps - Just (True, (_, h)) -> h`cmp`i - Just (False, _) -> False - - - - - - --- | narrow the search space: single capture first move -firstTurn :: Strategy -> Strategy -firstTurn s (GameTree node branches) rndgen - = s (GameTree node branches') rndgen - where branches' = [((m,Nothing),g) | ((m,Nothing), g)<-branches] - --- | narrow the search space: consider only capture-stacking turns -onlyCaptureStack :: Strategy -> Strategy -onlyCaptureStack s g rndgen = s (narrowTree g) rndgen - where - narrowTree :: BoardTree -> BoardTree - narrowTree (GameTree node@(b, (you,_)) branches) - | b = GameTree node [ ((m1,Just m2), narrowTree g) - | ((m1,Just m2), g)<-branches, - snd m2 `Map.member` you - ] - | otherwise = GameTree node [ (t, narrowTree g) | (t,g)<-branches ] - - +{- -- | eliminate double-captures that lead to the same board -narrowDoubleCaptures :: Strategy -> Strategy -narrowDoubleCaptures s g rndgen = s (nubTree g) rndgen +nubCaptures :: BoardTree -> BoardTree +nubCaptures (GameTree node branches) + = GameTree node $ nubBy equiv [(t, nubCaptures g) | (t,g)<-branches] where - nubTree :: BoardTree -> BoardTree - nubTree (GameTree node branches) - = GameTree node $ nubBy equiv [(t, nubTree g) | (t,g)<-branches] - where - equiv ((m1,Just m2),_) ((m2', Just m1'),_) - = fst m1/=fst m2 && m1==m1' && m2==m2' - equiv _ _ = False + equiv :: (Turn,BoardTree) -> (Turn,BoardTree) -> Bool + equiv ((m1,Just m2),_) ((m2', Just m1'),_) + = fst m1/=fst m2 && m1==m1' && m2==m2' + equiv _ _ = False - - --- | use different strategies dependening on the number of pieces left -ifPieces :: (Int -> Bool) -> Strategy -> Strategy -> Strategy -ifPieces cond s1 s2 g@(GameTree (_,(you,other)) branches) rndgen - | cond n = s1 g rndgen -- use the 1st strategy - | otherwise = s2 g rndgen -- use the 2nd strategy - where - n = Map.size you + Map.size other - - +-} diff --git a/src/AI/Utils.hs b/src/AI/Utils.hs --- a/src/AI/Utils.hs +++ b/src/AI/Utils.hs @@ -4,26 +4,20 @@ , mapTree , prunedepth , prunebreadth - , highfirst - , lowfirst + , prunebreadth_asc + -- , highfirst + -- , lowfirst + , ifPieces + , ifBranch + , singleCaptures + , dontPass ) where + import Board import Data.List (sortBy, minimumBy) - - --- | Searches BoardTree to a depth of 1 looking for a --- | guaranteed win or a preventable loss. -winOrPreventLoss :: Strategy -> Strategy -winOrPreventLoss s (GameTree a branches) = s $ GameTree a branches2 - where - winning = [ (t, b) | (t, b@(GameTree _ [])) <- branches ] - losing = [ t | (t, (GameTree _ branches')) <- branches, - (_, (GameTree _ [])) <- branches' ] - branches1 = if not $ null winning - then [head winning] - else if length branches<100 then [ (t, b) | (t, b) <- branches, notElem t losing ] else branches - branches2 = if null branches1 then [head branches] else branches1 +import qualified Data.Map as Map +import System.Random -- | some auxiliary functions over game trees @@ -38,28 +32,103 @@ = GameTree x [(f m,mapTree' f t) | (m,t)<-branches] --- heuristic to order subtrees with highest values first -highfirst, lowfirst :: - (Ord a) => GameTree a m -> GameTree a m + + +-- heuristic to order subtrees with highest/lowest values first +highfirst, lowfirst :: GameTree Int m -> GameTree Int m highfirst (GameTree x branches) - = GameTree x $ sortBy cmp [(m,lowfirst t) | (m,t)<-branches] - where cmp (_,GameTree x _) (_,GameTree y _) = compare y x + = GameTree x $ sortBy cmp [(m, lowfirst t) | (m,t)<-branches] + where cmp (_,x) (_,y) = compare (value y) (value x) + value (GameTree n _) = n lowfirst (GameTree x branches) = GameTree x $ sortBy cmp [(m,highfirst t) | (m,t)<-branches] - where cmp (_,GameTree x _) (_, GameTree y _) = compare x y + where cmp (_,x) (_, y) = compare (value x) (value y) + value (GameTree n _) = n + -- prune to a fixed depth prunedepth :: Int -> GameTree a m -> GameTree a m -prunedepth n (GameTree x branches) - | n>0 = GameTree x [(m,prunedepth (n-1) t) | (m,t)<-branches] - | otherwise = GameTree x [] +prunedepth 0 (GameTree x branches) = GameTree x [] +prunedepth (n+1) (GameTree x branches) + = GameTree x [(m,prunedepth n t) | (m,t)<-branches] -- prune to a fixed breadth prunebreadth :: Int -> GameTree a m -> GameTree a m -prunebreadth n (GameTree x branches) - = GameTree x [(m, prunebreadth n t) | (m,t)<-take n branches] +prunebreadth k (GameTree node branches) + = GameTree node [(m, prunebreadth k t) | (m,t)<-take k branches] +-- prune to a fixed breadth, ordering nodes by ascending static evalution +prunebreadth_asc :: Ord s => Int -> GameTree s m -> GameTree s m +prunebreadth_asc k (GameTree node branches) + = GameTree node branches' + where + branches' = take k $ + sortBy cmp [(m,prunebreadth_asc k t) | (m,t)<-branches] + cmp (_,x) (_, y) = compare (value x) (value y) + value (GameTree n _) = n + + + + +-- | use different strategies dependening on the number of pieces left +ifPieces :: (Int->Bool) -> Strategy -> Strategy -> Strategy +ifPieces p s1 s2 g@(GameTree (_,(you,other)) branches) rndgen + | p n = s1 g rndgen -- use the 1st strategy + | otherwise = s2 g rndgen -- use the 2nd strategy + where + n = Map.size you + Map.size other + +-- | use different strategies dependening on the branching factor +ifBranch :: (Int->Bool) -> Strategy -> Strategy -> Strategy +ifBranch p s1 s2 g@(GameTree (_,(you,other)) branches) rndgen + | p (length branches) = s1 g rndgen -- 1st strategy + | otherwise = s2 g rndgen -- 2nd strategy + + + +-- | Searches BoardTree to a depth of 1 looking for a +-- | guaranteed win or a preventable loss. +winOrPreventLoss :: Strategy -> Strategy +winOrPreventLoss s (GameTree a branches) = s $ GameTree a branches2 + where + winning = [ (t, b) | (t, b@(GameTree _ [])) <- branches ] +{- + losing = [ t | (t, (GameTree _ branches')) <- branches, + (_, (GameTree _ [])) <- branches' ] +-} + branches1 = (if not (null winning) + then [head winning] + else if length branches Strategy +singleCaptures s g@(GameTree _ branches) rndgen + | null branches' = s g rndgen + | otherwise = s g' rndgen + where + g'@(GameTree _ branches') = narrow g + narrow :: BoardTree -> BoardTree + narrow (GameTree node@(_, (you,_)) branches) + = GameTree node [ (t, narrow g) + | (t@(_,Just(_,dest)),g)<-branches, + dest`Map.member`you] + +-- don't consider pass moves +dontPass :: Strategy -> Strategy +dontPass s g rndgen = s (narrow g) rndgen + where + narrow :: BoardTree -> BoardTree + narrow (GameTree node branches) + = GameTree node [ (t, narrow g) | (t@(m1,Just m2),g)<-branches ] diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE BangPatterns #-} -- | Board State and AI module Board ( @@ -22,8 +22,7 @@ , nextCaptureMoves , nextStackingMoves , nextTurns - , connectedPositions - , threeLines + , countPieces , sixLines , atPosition , startingBoard @@ -32,13 +31,15 @@ , showMove , applyMove , applyTurn + , positions + , shuffle ) where import Data.List -import Data.Map (Map) +import Data.Map (Map, (!)) import qualified Data.Map as Map import System.Random -import Control.Monad(mplus) +import Control.Monad (mplus) -- | The board state is a pair of two "half-boards" (one per player) type Board = (HalfBoard, HalfBoard) @@ -46,13 +47,6 @@ -- | A Half-board maps locations to pieces type HalfBoard = Map Position Piece --- | A game tree with nodes s and moves m -data GameTree s m = GameTree s [(m, GameTree s m)] deriving Show - --- | A game tree of boards labeled with a boolean --- | True if it's max player's turn, False if min player's turn -type BoardTree = GameTree (Bool,Board) Turn - -- | The three types of pieces -- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts. data Type = Tzaar | Tzarra | Tott deriving (Show, Eq, Ord) @@ -80,6 +74,14 @@ -- | A complete turn is move, followed by an optional move. type Turn = (Move, Maybe Move) + +-- | A game tree with nodes s and moves m +data GameTree s m = GameTree s [(m, GameTree s m)] deriving Show + +-- | A game tree of boards labeled with a boolean +-- | True if it's white player's turn, False if black player's turn +type BoardTree = GameTree (Bool,Board) Turn + -- | An AI strategy calculates the next turn from a board tree. type Strategy = BoardTree -> StdGen -> (Turn, StdGen) @@ -90,9 +92,8 @@ , strategy :: Strategy -- ^ The strategy. } --- | The state of a single board position; Right true if you, Left if opponent. --- type AtPosition = Either Piece Piece + -- | List of all positions (for enumeration purposes) positions :: [Position] positions = [minBound .. maxBound] @@ -105,7 +106,6 @@ showMove (a, b) = show a ++ " -> " ++ show b - -- | Possible next turns. nextTurns :: Board -> [Turn] nextTurns board@(you, _) @@ -119,7 +119,7 @@ captureCapture = [ (a, Just b) | (a, x) <- zip a c, b <- x ] captureStack = [ (a, Just b) | (a, x) <- zip a d, b <- x ] captureNothing = zip a $ repeat Nothing - lostOneOfThree = length (nub [t | (t, _)<-Map.elems you]) /= 3 + lostOneOfThree = minimum (countPieces you) == 0 nextCaptureMoves :: Board -> [Move] @@ -138,6 +138,7 @@ nextStackingMoves :: Board -> [Move] nextStackingMoves board@(you, _) = concatMap forPiece (Map.keys you) where + (tzaars:tzarras:totts:_) = countPieces you forPiece :: Position -> [Move] forPiece p = concatMap downLine $ sixLines p where @@ -146,28 +147,39 @@ downLine (a:b) = case atPosition board a of Nothing -> downLine b Just (False, _) -> [] - Just (True, (Tzaar,_)) | oneTzaarRemaining -> [] - Just (True, (Tzarra,_)) | oneTzarraRemaining -> [] - Just (True, (Tott, _)) | oneTottRemaining -> [] + Just (True, (Tzaar,_)) | tzaars==1 -> [] + Just (True, (Tzarra,_)) | tzarras==1 -> [] + Just (True, (Tott, _)) | totts==1 -> [] Just (True, _) -> [(p, a)] - oneTzaarRemaining = 1 == Map.size (Map.filter (\(t,_)->t==Tzaar) you) - oneTzarraRemaining = 1 == Map.size (Map.filter (\(t,_)->t==Tzarra) you) - oneTottRemaining = 1 == Map.size (Map.filter (\(t,_)->t==Tott) you) +-- | count the number of pieces of each type in a half-board +countPieces :: HalfBoard -> [Int] +countPieces b + = count 0 0 0 [t | (t,_)<-Map.elems b] + where + count :: Int -> Int -> Int -> [Type] -> [Int] + count !x !y !z (Tzaar:ts) = count (1+x) y z ts + count !x !y !z (Tzarra:ts) = count x (1+y) z ts + count !x !y !z (Tott:ts) = count x y (1+z) ts + count !x !y !z [] = [x,y,z] + -- Creates a board tree for you and opponent. Assumes you have the next turn. boardTree :: Board -> BoardTree -boardTree board = mkTree True board +boardTree board = firstTurn (mkTree True board) where mkTree :: Bool -> Board -> BoardTree mkTree you b = GameTree (you,if you then b else swapBoard b) [ (t, mkTree (not you) $ swapBoard $ applyTurn b t) | t<-nextTurns b] - + -- consider single captures only for first move + firstTurn :: BoardTree -> BoardTree + firstTurn (GameTree node branches) = GameTree node branches' + where branches' = [t | t@((m,Nothing), g)<-branches] @@ -242,25 +254,29 @@ where (x, _:y) = span (/= a) b sixLines :: Position -> [[Position]] -sixLines p = Map.findWithDefault undefined p sixLines_memo - - +sixLines p = sixLines_memo!p -- | The next board state after a move. Assumes move is valid. applyMove :: Board -> Move -> Board applyMove board@(a, b) (x, y) - | fromA = (Map.insert y piece (Map.delete x a'), b') - | otherwise = (a', Map.insert y piece (Map.delete x b')) + | whoX = (Map.insert y piece (Map.delete x a), b') + | otherwise = (a', Map.insert y piece (Map.delete x b)) where - Just (whoX, (typeX, sizeX)) = atPosition board x - Just (whoY, (_ , sizeY)) = atPosition board y + whoX = Map.member x a + whoY = Map.member y a + (typeX, sizeX) | whoX = a!x + | otherwise = b!x + (_ , sizeY) | whoY = a!y + | otherwise = b!y capture = whoX /= whoY - fromA = Map.member x a - piece = (typeX, if capture then sizeX else sizeX + sizeY) - a' = Map.delete y a - b' = Map.delete y b + piece | capture = (typeX, sizeX) + | otherwise = (typeX, sizeX + sizeY) + a' | capture = Map.delete y a + | otherwise = a + b' | capture = Map.delete y b + | otherwise = b -- | The next board state after a complete turn. Assumes turn is valid. applyTurn :: Board -> Turn -> Board @@ -307,5 +323,6 @@ (ys,g'') = shuffle' g' (xs' ++ xs'') (n-1) in (x:ys, g'') | otherwise = ([],g) + diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -9,7 +9,7 @@ import Data.Function (on) import Data.Maybe (fromJust) import qualified Data.Map as Map -import Data.Map (Map) +import Data.Map (Map, (!)) import Data.List (minimumBy, sortBy) import Data.IORef import Control.Concurrent @@ -418,7 +418,7 @@ setSourceRGB 0.25 0.25 0) Black-> (setSourceRGB 0 0 0, setSourceRGB 1 1 1, - setSourceRGB 1 0.8 0) + setSourceRGB 1 0.75 0) stack 0 y = case t of Tott -> return () Tzarra -> crownColor >> disc 0.4 xc y @@ -555,11 +555,11 @@ boardPosition :: Position -> (Double,Double) -boardPosition p = Map.findWithDefault undefined p boardPositions +boardPosition p = boardPositions!p boardPositions :: Map Position (Double,Double) boardPositions - = Map.fromList + = Map.fromList [ (A1, p (-4) (-2)) , (A2, p (-4) (-1)) , (A3, p (-4) ( 0)) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,10 +1,79 @@ +-- Main module for Haskell TZAAR game implementation +-- Pedro Vasconcelos, 2010 module Main (main) where import Paths_hstzaar +import Board +import AI import GUI +import Tournament +import Tests +import System +import System.Random +import System.Console.GetOpt +import System.Exit +import Control.Monad (when) + +data Flag = Seed Int + | NumMatches Int + | RunTests + deriving Show + + +options :: [OptDescr Flag] +options = [Option ['s'] ["seed"] (ReqArg (Seed . read) "SEED") "random number seed", + Option ['n'] ["matches"] (ReqArg (NumMatches . read) "N") "number of matches (for AI tournaments)", + Option ['T'] ["tests"] (NoArg RunTests) "run QuickCheck tests" + ] + +parseArgs :: [String] -> IO ([Flag],[String]) +parseArgs argv + = case getOpt Permute options argv of + (flags, argv', []) -> return (flags, argv') + (_, _, errs) -> ioError $ + userError $ + concat errs ++ usageInfo header options ++ footer + +header, footer :: String +header = "usage: hstzaar [OPTION..] [AI AI]" +footer = " where AI is one of: " ++ unwords [name ai | ai<-ai_players] + + +-- default number of matches for AI tournaments +defMatches :: Int +defMatches = 10 + +processFlags :: [Flag] -> IO Int +processFlags flags = process flags defMatches + where + process [] m = return m + process (RunTests:flags) m = run_tests >> exitSuccess + process (Seed s:flags) m = setStdGen (mkStdGen s) >> process flags m + process (NumMatches n:flags) _ = process flags n + + + main :: IO () -main = do - gladepath <- getDataFileName "data/hstzaar.glade" - gui gladepath +main = do argv<-getArgs + (flags, argv')<- parseArgs argv + numMatches <- processFlags flags + -- + case argv' of + [] -> do gladepath <- getDataFileName "data/hstzaar.glade" + gui gladepath + [a1,a2] -> do p1<-string_to_AI a1 + p2<-string_to_AI a2 + let numboards = max 1 (numMatches`div`2) + rndgen <- getStdGen + let (boards, rnd) = randomBoards numboards rndgen + playAIs p1 p2 boards rnd + _ -> ioError $ userError $ usageInfo header options ++ footer + +string_to_AI :: String -> IO AI +string_to_AI n + = case [p | p<-ai_players, name p==n] of + [] -> ioError $ userError ("invalid AI: " ++ n) + (p:_) -> return p + diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Tests.hs @@ -0,0 +1,236 @@ +{- + 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)) + ] + diff --git a/src/Tournament.hs b/src/Tournament.hs new file mode 100644 --- /dev/null +++ b/src/Tournament.hs @@ -0,0 +1,61 @@ +-- Competitions between diferent AIs +module Tournament where + +import AI.Minimax +import AI.Lame +import Board +import System.Random +import Control.Monad + +-- compare two strategies on a starting board +-- plays 2 games with (either strategy first) and sums the results +-- result is 1 , 0 or -1 according to the relative comparision +playMatch :: AI -> AI -> Board -> StdGen -> IO Int +playMatch p1 p2 startboard rndgen + = playMatch' 1 (boardTree startboard) rndgen p1 p2 + +playMatch' :: Int -> BoardTree -> StdGen -> AI -> AI -> IO Int +playMatch' n bt@(GameTree _ branches) rnd p1 p2 + | null branches -- first player can't play: second player wins + = return (-1) + | otherwise + = do putStrLn (show n ++ ". " ++ name p1 ++ ":\t" ++ showTurn t) + liftM negate $ playMatch' (n+1) bt' rnd' p2 p1 + where (t, rnd') = strategy p1 bt rnd + bt' = swapBoardTree $ head [bt' | (t',bt')<-branches, t'==t] + --k = length branches + + + +-- compare two strategies on random boards +playAIs :: AI -> AI -> [Board] ->StdGen -> IO () +playAIs p1 p2 boards rnd + = do rs<-sequence ([do header i + r<-playMatch p1 p2 b rnd + footer + return r + | (i,b)<-zip [1..] boards] ++ + [do header i + r<-playMatch p2 p1 b rnd + footer + return (-r) + | (i,b)<- zip [n+1..] boards + ]) + let won = length [r | r<-rs, r>0] + let lost= length [r | r<-rs, r<0] + let score = sum rs + putStrLn (name p1 ++ " vs " ++ name p2 ++ ": " + ++ show score ++ " (" + ++ show won ++ " matches won and " + ++ show lost ++ " lost)") + where n = length boards + header i = putStrLn ("Match " ++ show i ++ "/" ++ show (2*n)) + footer = putStrLn (replicate 80 '-') + + +-- create random boards +randomBoards :: Int -> StdGen -> ([Board], StdGen) +randomBoards 0 rndgen = ([], rndgen) +randomBoards (n+1) rndgen = (b:bs, rndgen'') + where (b, rndgen') = randomBoard rndgen + (bs, rndgen'') = randomBoards n rndgen'