hstzaar 0.3 → 0.4
raw patch · 13 files changed
+833/−309 lines, 13 filesdep +QuickCheckdep +haskell98
Dependencies added: QuickCheck, haskell98
Files
- README +89/−0
- RELEASE-NOTES +6/−0
- hstzaar.cabal +7/−4
- src/AI.hs +6/−2
- src/AI/Eval.hs +121/−0
- src/AI/Lame.hs +12/−1
- src/AI/Minimax.hs +71/−233
- src/AI/Utils.hs +96/−27
- src/Board.hs +52/−35
- src/GUI.hs +4/−4
- src/Main.hs +72/−3
- src/Tests.hs +236/−0
- src/Tournament.hs +61/−0
+ README view
@@ -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+
RELEASE-NOTES view
@@ -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
hstzaar.cabal view
@@ -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
src/AI.hs view
@@ -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]]+
+ src/AI/Eval.hs view
@@ -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+ ++
src/AI/Lame.hs view
@@ -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
src/AI/Minimax.hs view
@@ -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--+-}
src/AI/Utils.hs view
@@ -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<cutoff + then [ (t,b) | (t,b)<-branches, not_losing b] + else branches)+ branches2 = if null branches1 then [head branches] else branches1+ not_losing (GameTree _ branches) + = null [t | (t, GameTree _ []) <- branches]+ cutoff = 100 -- braching upper bound for searching losing moves++++-- | narrow the search space: don't consider double-capture or pass moves+singleCaptures :: Strategy -> 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 ]
src/Board.hs view
@@ -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)+
src/GUI.hs view
@@ -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))
src/Main.hs view
@@ -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+
+ src/Tests.hs view
@@ -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))+ ]+
+ src/Tournament.hs view
@@ -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'