hstzaar 0.8.2 → 0.9
raw patch · 16 files changed
+1451/−1282 lines, 16 filesdep +xml
Dependencies added: xml
Files
- RELEASE-NOTES +11/−0
- hstzaar.cabal +8/−6
- hstzaar.glade +151/−62
- src/AI.hs +24/−26
- src/AI/Eval.hs +39/−80
- src/AI/Minimax.hs +46/−61
- src/AI/Tree.hs +169/−0
- src/AI/Utils.hs +0/−145
- src/Board.hs +292/−383
- src/GUI.hs +314/−298
- src/History.hs +0/−67
- src/Main.hs +5/−5
- src/Serialize.hs +133/−0
- src/Tests.hs +230/−72
- src/Tournament.hs +29/−28
- src/Var.hs +0/−49
RELEASE-NOTES view
@@ -1,3 +1,14 @@+hstzaar 0.9 14/02/2012+- corrected error in game tree generation (didn't check end of game properly)+- improved the AI evaluation function; plays much better now+- refactored the game tree code into a separate module (Tree.hs)+- cleaned up the GUI code using MVars instead of IORefs+- added the option for human to play white or black+- following the board game rules, the default is now to play+ the randomized board with an option for the fixed position +- changed the save game format to an implementation-independent XML;+ old saved games no longer work, but future releases should be backwards-compatible+ hstzaar 0.8.2 31/10/2011 - tweaked the AI evaluation function; should play better now - AI level 1 is now default
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.8.2+version: 0.9 category: Game @@ -12,13 +12,13 @@ This program is based on the (retired) htzaar implementation by Tom Hawkins <tomahawkins@gmail.com>. -author: Pedro Vasconcelos <pbv@ncc.up.pt>-maintainer: Pedro Vasconcelos <pbv@ncc.up.pt>+author: Pedro Vasconcelos <pbv@dcc.fc.up.pt>+maintainer: Pedro Vasconcelos <pbv@fcc.fc.up.pt> license: BSD3 license-file: LICENSE -homepage: http://www.ncc.up.pt/~pbv/stuff/hstzaar+homepage: http://www.dcc.fc.up.pt/~pbv/stuff/hstzaar build-type: Simple cabal-version: >= 1.6@@ -30,7 +30,7 @@ executable hstzaar hs-source-dirs: src main-is: Main.hs- other-modules: GUI Var History Board AI AI.Utils AI.Eval AI.Minimax Tournament Tests+ other-modules: GUI Serialize Board AI AI.Tree AI.Eval AI.Minimax Tournament Tests build-depends: base >= 4 && < 5, haskell98,@@ -41,6 +41,8 @@ cairo >= 0.11, glade >= 0.11, random >= 1.0.0 && < 1.1,- QuickCheck >= 2.1+ QuickCheck >= 2.1,+ xml >= 1.3 + ghc-options: -threaded ghc-prof-options: -prof -auto-all
hstzaar.glade view
@@ -2,6 +2,71 @@ <glade-interface> <!-- interface-requires gtk+ 2.16 --> <!-- interface-naming-policy toplevel-contextual -->+ <widget class="GtkAboutDialog" id="aboutdialog">+ <property name="border_width">5</property>+ <property name="window_position">center</property>+ <property name="type_hint">normal</property>+ <property name="gravity">center</property>+ <property name="program_name">HsTZAAR</property>+ <property name="version">0.0</property>+ <property name="copyright" translatable="yes">Copyright (c) Tom Hawkins & Pedro Vasconcelos 2011</property>+ <property name="comments" translatable="yes">A computer program to play the board game TZAAR designed by Kris Burm in 2007 as the final part of the GIPF series of abstract strategy games.++Programmed using the Haskell programming language, GTK+ toolkit and Cairo graphic libraries.+Windows installer built using Inno Setup.+</property>+ <property name="website">http://www.dcc.fc.up.pt/~pbv/stuff/hstzaar</property>+ <property name="license" translatable="yes">+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.+</property>+ <property name="authors">Pedro Vasconcelos <pbv@dcc.fc.up.pt>.+Based on the HTZAAR program by Tom Hawkins <tomhawkins.org>.+</property>+ <child internal-child="vbox">+ <widget class="GtkVBox" id="dialog-vbox2">+ <property name="visible">True</property>+ <property name="spacing">2</property>+ <child>+ <placeholder/>+ </child>+ <child internal-child="action_area">+ <widget class="GtkHButtonBox" id="dialog-action_area2">+ <property name="visible">True</property>+ <property name="layout_style">end</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="pack_type">end</property>+ <property name="position">0</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget> <widget class="GtkWindow" id="mainwindow"> <property name="title" translatable="yes">HsTZAAR</property> <property name="default_width">600</property>@@ -110,13 +175,6 @@ <widget class="GtkMenu" id="menu4"> <property name="visible">True</property> <child>- <widget class="GtkCheckMenuItem" id="menu_item_random_start">- <property name="visible">True</property>- <property name="label" translatable="yes">Random start position</property>- <property name="use_underline">True</property>- </widget>- </child>- <child> <widget class="GtkCheckMenuItem" id="menu_item_draw_stacks"> <property name="visible">True</property> <property name="label" translatable="yes">Draw stacks</property>@@ -143,7 +201,7 @@ <child> <widget class="GtkMenuItem" id="menuitem4"> <property name="visible">True</property>- <property name="label" translatable="yes">_AI</property>+ <property name="label" translatable="yes">_AI opponent</property> <property name="use_underline">True</property> <child> <widget class="GtkMenu" id="menu_ai">@@ -204,23 +262,27 @@ <child> <widget class="GtkHBox" id="hbox1"> <property name="visible">True</property>- <property name="homogeneous">True</property> <child>- <widget class="GtkProgressBar" id="progressbar">+ <widget class="GtkStatusbar" id="statusbar"> <property name="visible">True</property>- <property name="ellipsize">end</property>+ <property name="spacing">2</property>+ <property name="has_resize_grip">False</property> </widget> <packing>- <property name="position">0</property>+ <property name="padding">4</property>+ <property name="position">1</property> </packing> </child> <child>- <widget class="GtkStatusbar" id="statusbar">+ <widget class="GtkProgressBar" id="progressbar"> <property name="visible">True</property>- <property name="spacing">2</property>+ <property name="ellipsize">end</property> </widget> <packing>- <property name="position">1</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="padding">2</property>+ <property name="position">2</property> </packing> </child> </widget>@@ -232,61 +294,88 @@ </widget> </child> </widget>- <widget class="GtkAboutDialog" id="aboutdialog1">+ <widget class="GtkDialog" id="startdialog"> <property name="border_width">5</property>- <property name="window_position">center</property>- <property name="type_hint">normal</property>- <property name="gravity">center</property>- <property name="program_name">HsTZAAR</property>- <property name="version">0.0</property>- <property name="copyright" translatable="yes">Copyright (c) Tom Hawkins & Pedro Vasconcelos 2011</property>- <property name="comments" translatable="yes">A computer program to play the board game TZAAR designed by Kris Burm in 2007 as the final part of the GIPF series of abstract strategy games.--Programmed using the Haskell programming language, the GTK+ toolkit and the Cairo graphic libraries.-Windows installer assembled using Inno Setup.-</property>- <property name="website">http://www.dcc.fc.up.pt/~pbv/stuff/hstzaar</property>- <property name="license" translatable="yes">-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.-3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.-</property>- <property name="authors">Pedro Vasconcelos <pbv@dcc.fc.up.pt>.-Based on the HTZAAR program by Tom Hawkins <tomhawkins.org>.-</property>+ <property name="title" translatable="yes">New game</property>+ <property name="resizable">False</property>+ <property name="modal">True</property>+ <property name="destroy_with_parent">True</property>+ <property name="type_hint">dialog</property> <child internal-child="vbox">- <widget class="GtkVBox" id="dialog-vbox2">+ <widget class="GtkVBox" id="dialog-vbox3"> <property name="visible">True</property> <property name="spacing">2</property> <child>- <placeholder/>+ <widget class="GtkCheckButton" id="fixedposition">+ <property name="label" translatable="yes">Fixed start position</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">False</property>+ <property name="draw_indicator">True</property>+ </widget>+ <packing>+ <property name="position">0</property>+ </packing> </child>+ <child>+ <widget class="GtkRadioButton" id="playwhite">+ <property name="label" translatable="yes">Play White</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">False</property>+ <property name="active">True</property>+ <property name="draw_indicator">True</property>+ <property name="group">playblack</property>+ </widget>+ <packing>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <widget class="GtkRadioButton" id="playblack">+ <property name="label" translatable="yes">Play Black</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">False</property>+ <property name="active">True</property>+ <property name="draw_indicator">True</property>+ <property name="group">playwhite</property>+ </widget>+ <packing>+ <property name="position">3</property>+ </packing>+ </child> <child internal-child="action_area">- <widget class="GtkHButtonBox" id="dialog-action_area2">+ <widget class="GtkHButtonBox" id="dialog-action_area3"> <property name="visible">True</property>- <property name="layout_style">end</property>+ <property name="layout_style">spread</property>+ <child>+ <widget class="GtkButton" id="dialog_cancel">+ <property name="label" translatable="yes">Cancel</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkButton" id="dialog_start">+ <property name="label" translatable="yes">Start game</property>+ <property name="response_id">1</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child> </widget> <packing> <property name="expand">False</property>
src/AI.hs view
@@ -2,42 +2,40 @@ module AI (aiPlayers) where import Board-import AI.Utils+import AI.Tree import AI.Minimax import AI.Eval -- import Debug.Trace -- all AI players; ply depth >1 do not necessarily play better! aiPlayers :: [(String,AI)]-aiPlayers = ("level0",basic) : [("level"++show n, ply n) | n<-[1,2,3]]+aiPlayers = [ (l,ply l d) | n<-[0..3], let d=max 1 (2*n+1), let l="Level "++show n] +{-++aiPlayers = zipWith (\n ai -> (n,ai n)) names levels+ where levels = basic : [ply (3*n) | n<-[1,2,3]]+ names = ["Level " ++ show n | n<-[0..3]]+ -- basic AI: material evaluation, depth 1-basic = AI { name = "Level 0"- , description = "Minimax alpha-beta depth 2 (eval0)"- , strategy = negamaxStrategy 2 eval0- }+basic n = AI { name = n+ , description = "Minimax alpha-beta depth 3"+ , strategy = negamaxStrategy 3 eval0+ }+-} + -- better AI, parameterized by ply depth-ply :: Int -> AI-ply d = AI { name = "Level " ++ show d- , description = - "Minimaxing alpha-beta depth " ++ show (2*d) ++ " (eval1)"- , strategy = withStacks $ \n ->- -- increase depth inversely linear with number of stacks- let d' = roundup (((60-n)*2*d)`div`60 + 1)- in negamaxStrategy d' eval1+ply :: String -> Int -> AI+ply n d = AI { name = n+ , description = "Minimaxing with alpha-beta ply " ++ show d+ , strategy = singleMoves $ negamaxStrategy d eval1+ {-+ withBoard $ + \b -> let m = minimum (countStacks (active b) (pieces b) +++ countStacks (inactive b) (pieces b))+ d' = if m<=3 then d else 3+ in negamaxStrategy d' eval1 -} }- where roundup n = max 2 n -- + n`mod`2 -{--level2 = AI { name = "Level 2"- , description = "Minimaxing alpha-beta depth 2-4 (eval1)"- , strategy = (withNPieces $ \numpieces -> - if numpieces<30 then- minimaxStrategy 4 eval1- else- minimaxStrategy 2 eval1- )- }--}
src/AI/Eval.hs view
@@ -1,91 +1,50 @@ {-# LANGUAGE BangPatterns #-} -- Static evaluation functions for board positions-module AI.Eval( eval0, - eval1- ) where-+module AI.Eval where import Board-import AI.Utils (zoneOfControl)-import qualified Data.IntMap as IntMap----- | Static evaluation of a position for the active player--- | Level 0: material only-eval0 :: Board -> Int-eval0 b- | any (==0) counts || (move b==1 && null captures) = -infinity- | any (==0) counts' = infinity- | otherwise = material- where- -- count stacks by piece kind for each player - counts = countStacks (active b)- counts'= countStacks (inactive b)-- -- capture moves for active player- captures = nextCaptureMoves b- -- captures'= nextCaptureMoves (swapBoard b) - - -- stack heights by piece kinds- heights = sumHeights (active b)- heights'= sumHeights (inactive b)-- -- material score - material = sum [(mw*h)`div`c | (c,h)<-zip counts heights] - - sum [(mw*h)`div`c | (c,h)<-zip counts' heights'] -- -- scoreing weights coeficients- mw = 100 -- material - -+import AI.Tree (infinity) --- | Level >=1: material + positional +-- | Static board evaluation function +-- considers material and positional scores eval1 :: Board -> Int eval1 b- | any (==0) counts || (move b==1 && null captures) = -infinity- | any (==0) counts' || not (null threats) = infinity- | otherwise = material + positional - where- -- count stacks by piece kind for each player - counts = countStacks (active b)- counts'= countStacks (inactive b)+ | null moves = -infinity+-- | any (==0) counts' = infinity -- this should *NOT* be necessary + | otherwise = material b + positional b+ where moves = nextMoves b -- active player's moves - -- capture moves for active player- captures = nextCaptureMoves b- --captures'= nextCaptureMoves (swapBoard b) -- -- stack heights by piece kinds- heights = sumHeights (active b)- heights'= sumHeights (inactive b)-- -- material score - material = sum [(mw*h)`div`c | (c,h)<-zip counts heights] -- sum [(mw*h)`div`c | (c,h)<-zip counts' heights']-- -- zone of control of the active player - zoc = zoneOfControl b- -- positional score - zoc_heights = sumHeights zoc- zoc_counts = countStacks zoc- positional = sum [(pw*h)`div`c | (c,h)<-zip counts' zoc_heights] - - -- immediate threats to opponent's pieces- threats = [undefined | (x,y)<-zip counts' zoc_counts, move b+x<=3 && x==y]- - -- scoreing weights coeficients- mw = 100 -- material weight- pw = 100 -- positional weight- --+-- | Material score+-- * multiply sum of heights by counts +-- * height weights for kinds with lowest counts+material :: Board -> Int+{-# INLINE material #-}+material b = (sum [(30-n)*h | (n,h)<-zip counts heights] -+ sum [(30-n)*h | (n,h)<-zip counts' heights'])+ where + -- stacks counts by piece kinds for each player + counts = activeCounts b+ counts'= inactiveCounts b+ -- sum of heights by piece kinds+ heights = activeHeights b+ heights'= inactiveHeights b+ --- sum of heights of stacks for each kind-sumHeights :: HalfBoard -> [Int]-sumHeights b = sum 0 0 0 (IntMap.elems b)- where sum :: Int -> Int -> Int -> [Piece] -> [Int]- sum !x !y !z ((Tzaar,h):ps) = sum (x+h) y z ps- sum !x !y !z ((Tzarra,h):ps) = sum x (y+h) z ps- sum !x !y !z ((Tott,h):ps) = sum x y (z+h) ps- sum !x !y !z [] = [x,y,z]+-- | Positional score+-- for each kind, count opponent's pieces in each player's zone of control +positional :: Board -> Int+{-# INLINE positional #-}+positional b = (sum [pw*m`div`n | (n,m)<-zip counts' zoc_counts] -+ sum [pw*m`div`n | (n,m)<-zip counts zoc_counts'])+ where + counts = activeCounts b+ counts'= inactiveCounts b+ -- zone of control of each player+ zoc = zoneOfControl (active b) (pieces b)+ zoc'= zoneOfControl (inactive b) (pieces b)+ -- count pieces in each zone of control+ zoc_counts= countStacks (inactive b) zoc+ zoc_counts'= countStacks (active b) zoc'+ pw = 100
src/AI/Minimax.hs view
@@ -1,100 +1,85 @@ {-# LANGUAGE BangPatterns #-}-module AI.Minimax( EvalFunc- , negamaxStrategy+module AI.Minimax( negamaxStrategy , negamax , negamax_ab , negamaxPV ) where -import AI.Utils+import AI.Tree import Board -- import Debug.Trace --- | type of static evaluation functions-type EvalFunc = Board -> Int -- | Negamax with alpha-beta and static depth prunning -negamaxStrategy :: Int -> EvalFunc -> Strategy-negamaxStrategy n evf bt rndgen +negamaxStrategy :: Int -> Eval -> Strategy+negamaxStrategy depth eval bt rndgen | isEmptyTree bt = error "negamaxStrategy: empty tree"-negamaxStrategy n evf bt rndgen - = ((m1,m2), rndgen)- where (bestscore, m1:m2:_) = negamaxPV bt'- bt' = pruneDepth n $ -- ^ prune to depth `n'- mapTree evf bt -- ^ apply static evaluation function+negamaxStrategy depth eval bt rndgen + = (score, m, rndgen)+ where (score, m:_) = negamaxPV $ + pruneDepth depth $ -- ^ prune evaluation tree+ mapTree eval bt -- ^ apply static evaluation function -- | Naive negamax algorithm (not used) -- | nodes values are static evaluation scores-negamax :: (Num a, Ord a) => GameTree a m -> a -negamax = negamax' 0--negamax' :: (Num a, Ord a) => Int -> GameTree a m -> a -negamax' depth (GameTree x []) = x-negamax' depth (GameTree _ branches) - | odd depth = - minimum vs- | otherwise = maximum vs- where vs = map (negamax' (1+depth) . snd) branches+negamax :: (Num a, Ord a) => GameTree a m -> a +negamax (GameTree x []) = x+negamax (GameTree _ branches) = - minimum vs+ where vs = map (negamax . snd) branches --- | Negamax with alpha-beta prunning-negamax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a-negamax_ab = negamax_ab' 0--negamax_ab' :: (Num a, Ord a) => Int -> a -> a -> GameTree a m -> a-negamax_ab' depth a b (GameTree x []) = a `max` x `min` b-negamax_ab' depth a b (GameTree _ branches) = cmx a b (map snd branches)+-- | Negamax with alpha-beta prunning; +-- computes the minimax value but not the best move+negamax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a+negamax_ab a b (GameTree x []) = a `max` x `min` b+negamax_ab a b (GameTree _ branches) = cmx a b (map snd branches) where cmx a b [] = a cmx a b (t:ts) | a'==b = a' | otherwise = cmx a' b ts- where a' | odd depth = -negamax_ab' (1+depth) (-b) (-a) t- | otherwise = negamax_ab' (1+depth) a b t+ where a' = - negamax_ab (-b) (-a) t --- | Principal Variantions-data PV = PV !Int [Move] deriving (Show) -instance Eq PV where- (PV x _) == (PV y _) = x==y -instance Ord PV where- compare (PV x _) (PV y _) = compare x y -instance Num PV where+-- | pair a evaluation score with something+newtype PV a = PV (Int,a) deriving (Show)++instance Eq (PV a) where+ (PV (x,_)) == (PV (y,_)) = x==y++instance Ord (PV a) where+ compare (PV (x,_)) (PV (y,_)) = compare x y++instance Show a => Num (PV a) where (+) = undefined (-) = undefined (*) = undefined fromInteger = undefined signum = undefined abs = undefined- negate (PV x ms) = PV (-x) ms+ negate (PV (x,m)) = PV (negate x,m) -{--negatePV :: PV -> PV-negatePV (PV x ms) = PV (-x) ms--} -- | Negamax with alpha-beta pruning--- | extended with score and principal variation +-- computes both minimax value and the best move (start of principal variation) negamaxPV :: GameTree Int Move -> (Int, [Move])-negamaxPV bt - = case negamaxPV_ab 0 [] lo hi bt of- PV v ms -> (v, reverse ms)- where lo = PV (-maxBound) []- hi = PV maxBound []+negamaxPV bt+ = case negamaxPV_ab [] lo hi bt of+ PV (v,ms) -> (v,reverse ms)+ where lo = PV (-infinity, []) -- dummy bounds+ hi = PV ( infinity, [])+ -- m = fst (head branches) --- | depth parameter determines if we negate children scores--- | negamaxPV_ab :: (Num a, Ord a) => Int -> [m] -> a -> a -> GameTree a m -> (a, [m])-negamaxPV_ab depth ms a b (GameTree x []) = a `max` PV x ms `min` b-negamaxPV_ab depth ms a b (GameTree _ branches) = cmx a b branches+negamaxPV_ab :: [Move] -> PV [Move] -> PV [Move] -> GameTree Int Move -> PV [Move]+negamaxPV_ab ms a b (GameTree x []) = a `max` (PV (x,ms)) `min` b+negamaxPV_ab ms a b (GameTree _ branches) = cmx a b branches where - cmx a b [] = a- cmx a b ((m,t) : branches) - | a'>=b = a'- | otherwise = cmx a' b branches- where a' = if odd depth - then - negamaxPV_ab (1+depth) (m:ms) (-b) (-a) t - else negamaxPV_ab (1+depth) (m:ms) a b t--+ cmx x y [] = x+ cmx x y ((m,t) : rest) + | x'==y = x'+ | otherwise = cmx x' y rest+ where x' = - negamaxPV_ab (m:ms) (-y) (-x) t +
+ src/AI/Tree.hs view
@@ -0,0 +1,169 @@+-- | Utilities for computing AI game trees+module AI.Tree+ ( BoardTree+ , GameTree(..)+ , Strategy+ , AI (..)+ , Eval+ , boardTree+ -- , startBoardTree+ , mapTree+ , mapTree'+ , isEmptyTree+ , infinity+ -- , winOrPreventLoss+ , pruneDepth, pruneBreadth+ , highFirst, lowFirst+ , withBoard+ , singleMoves+ -- , dontPass, singleCaptures + ) where++import Board+import Data.List (nubBy, sortBy, minimumBy)+import qualified Data.Map as Map+import System.Random++-- | A game tree with nodes s and moves m+data GameTree s m = GameTree s [(m, GameTree s m)] + deriving Show++-- | auxiliary functions over game trees+-- | apply a function to each node+mapTree :: (a->b) -> GameTree a m -> GameTree b m+mapTree f (GameTree x branches) + = GameTree (f x) [(m,mapTree f t) | (m,t)<-branches]++-- | apply a function to each edge+mapTree' :: (a->b) -> GameTree s a -> GameTree s b+mapTree' f (GameTree x branches) + = GameTree x [(f m,mapTree' f t) | (m,t)<-branches]++-- | test for empty branches+isEmptyTree :: GameTree a m -> Bool+isEmptyTree (GameTree _ []) = True+isEmptyTree _ = False+++-- | A game tree of boards labeled by moves+type BoardTree = GameTree Board Move++-- | An AI strategy calculates the next turn from a board tree.+-- result: evaluation score, next move, next random generator+type Strategy = BoardTree -> StdGen -> (Int, Move, StdGen)++-- | An AI player.+data AI = AI+ { name :: String -- ^ Name of AI.+ , description :: String -- ^ Brief description of AI.+ , strategy :: Strategy -- ^ The strategy.+ }++-- | type of static evaluation functions+type Eval = Board -> Int ++-- | maximum absolute value of static evaluation +infinity :: Int+infinity = 2^20+++-- | Create a board tree from a board position+boardTree :: Board -> BoardTree+boardTree b = GameTree b [(m, boardTree (applyMove m b)) | m<-nextMoves b]+++-- | order subtrees with ascending or descending order (not used)+highFirst, lowFirst :: GameTree Int m -> GameTree Int m+highFirst (GameTree x branches) + = GameTree x [(m,highFirst t) | (m,t)<-sortBy cmp branches] + where cmp (_,x) (_,y) = compare (value y) (value x)+ value (GameTree n _) = n++lowFirst (GameTree x branches) + = GameTree x [(m,lowFirst t) | (m,t)<-sortBy cmp branches]+ where cmp (_,x) (_, y) = compare (value x) (value y)+ value (GameTree n _) = n++++-- | prune a game tree 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 []+++-- | prune a game tree to a fixed breadth (not used)+pruneBreadth :: Int -> GameTree a m -> GameTree a m+pruneBreadth k (GameTree node branches) + = GameTree node [(m,pruneBreadth k t) | (m,t)<-take k branches]+++ +-- | conditional strategy (depending on the board state)+withBoard :: (Board -> Strategy) -> Strategy+withBoard f t@(GameTree b _) g = f b t g++-- number of stacks of both players+-- withStacks :: (Int -> Strategy) -> Strategy+-- withStacks f = withBoard $ \b -> f (IntMap.size (active b) + IntMap.size (inactive b))++-- | avoid search when only move is available+singleMoves :: Strategy -> Strategy+singleMoves s (GameTree b [(m,_)]) rnd = (0, m, rnd)+singleMoves s bt rnd = s bt rnd+++{-+-- | Searches BoardTree to a depth of 1 looking for a +-- | guaranteed win or a preventable loss.+winOrPreventLoss :: Strategy -> Strategy+winOrPreventLoss s (GameTree node branches) = s $ GameTree node branches2+ where+ -- ensure a win in 1 or 2 captures+ winning = [ (m, t) | (m,t@(GameTree b _))<-branches, endGame b]+ -- prevent a loss+ prevent_loss = [(m1,t1) | (m1,t1@(GameTree _ branches'))<-branches,+ (m2,t2)<- branches', not_losing t2]+ + branches1 = (if not (null winning) + then [head winning]+ else prevent_loss+ )+ branches2 = if null branches1 then [head branches] else branches1+ not_losing (GameTree _ branches) + = null [m | (m, GameTree b _) <- branches, endGame b]+ cutoff = 1000 -- 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 board branches)+ = GameTree board [ (m, narrow g) | (m,g)<-branches,+ move board==1 || isStacking m ]+ isStacking (Stack _ _) = True+ isStacking _ = False++-- don't consider passing moves +dontPass :: Strategy -> Strategy+dontPass s g rndgen = s (narrow g) rndgen+ where+ narrow :: BoardTree -> BoardTree+ narrow (GameTree node branches) + | null branches' = GameTree node branches+ | otherwise = GameTree node branches'+ where branches' = [(m, narrow g) | (m,g)<-branches, m/=Pass]+-}++++++
− src/AI/Utils.hs
@@ -1,145 +0,0 @@--- | Utilities for AI players.-module AI.Utils- ( winOrPreventLoss- , pruneDepth, pruneBreadth- , highFirst, lowFirst- , withStacks, withBoard- , dontPass, singleCaptures - , zoneOfControl- ) where--import Board-import Data.List (nubBy, sortBy, minimumBy)-import qualified Data.IntMap as IntMap-import System.Random----- order subtrees with ascending or descending order of static evaluation-highFirst, lowFirst :: GameTree Int m -> GameTree Int m-highFirst (GameTree x branches) - = GameTree x [(m,highFirst t) | (m,t)<-sortBy cmp branches] - where cmp (_,x) (_,y) = compare (value y) (value x)- value (GameTree n _) = n--lowFirst (GameTree x branches) - = GameTree x [(m,lowFirst t) | (m,t)<-sortBy cmp branches]- 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 []---- prune to a fixed breadth-pruneBreadth :: Int -> GameTree a m -> GameTree a m-pruneBreadth k (GameTree node branches) - = GameTree node [(m,pruneBreadth k t) | (m,t)<-take k branches]--- --- conditional strategies-withBoard :: (Board -> Strategy) -> Strategy-withBoard f t@(GameTree b _) g = f b t g---- number of stacks of both players-withStacks :: (Int -> Strategy) -> Strategy-withStacks f = withBoard $ \b -> f (IntMap.size (active b) + IntMap.size (inactive b))------ | Searches BoardTree to a depth of 1 looking for a --- | guaranteed win or a preventable loss.-winOrPreventLoss :: Strategy -> Strategy-winOrPreventLoss s (GameTree node branches) = s $ GameTree node branches2- where- -- ensure a win in 1 or 2 captures- winning = [ (m, t) | (m,t@(GameTree b _))<-branches, endGame b]- -- prevent a loss- prevent_loss = [(m1,t1) | (m1,t1@(GameTree _ branches'))<-branches,- (m2,t2)<- branches', not_losing t2]- - branches1 = (if not (null winning) - then [head winning]- else prevent_loss- )- branches2 = if null branches1 then [head branches] else branches1- not_losing (GameTree _ branches) - = null [m | (m, GameTree b _) <- branches, endGame b]- cutoff = 1000 -- 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 board branches)- = GameTree board [ (m, narrow g) | (m,g)<-branches,- move board==1 || isStacking m ]- isStacking (Stack _ _) = True- isStacking _ = False---- don't consider passing moves -dontPass :: Strategy -> Strategy-dontPass s g rndgen = s (narrow g) rndgen- where- narrow :: BoardTree -> BoardTree- narrow (GameTree node branches) - | null branches' = GameTree node branches- | otherwise = GameTree node branches'- where branches' = [(m, narrow g) | (m,g)<-branches, m/=Pass]------- Estimate the zone of control of the active player--- i.e., the set of opponent pieces reachable in a turn (two capture moves)-zoneOfControl :: Board -> HalfBoard-zoneOfControl board- = IntMap.filterWithKey forPiece1 other- where- you = active board- other = inactive board- who = playerColor board- -- white pieces that can make at least one capture- captures = IntMap.filterWithKey forPiece2 you-- 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 (who', (_, h)) | who'==who -> - h>=i || (p`IntMap.member`captures && downLine1 i ps)- Just (_, (_, 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 (who', (_, h)) | who'==who -> h>=i- _ -> False-- downLine2 h [] = False- downLine2 h (p:ps) - = case atPosition board p of- Nothing -> downLine2 h ps- Just (who', (_, i)) | who'/=who -> h>=i- _ -> False---
src/Board.hs view
@@ -1,90 +1,80 @@ {-# LANGUAGE BangPatterns #-}--- | Board State and AI+-- | Board State module Board- (- -- * Types+ ( -- * Types Board (..)- --, move- --, player- --, active- --, inactive- , whites- , blacks- , boardSize- , HalfBoard- , BoardTree- , GameTree(..)- , Type (..)+ , PieceMap+ , Color (..)+ , Kind (..) , Piece- , Position- , APosition (..)- , fromAPos- , toAPos+ , Position (..) , Move (..)- , Turn- -- , AtPosition- , Strategy- , AI (..)- -- * Utilities- , boardTree- , startBoardTree- , mapTree- , mapTree'- , isEmptyTree+ , Game (..)+ , initBoard+ , initGame+ , color, kind, height -- attributes of pieces + , nthTurn, nthMove+ , invert+ , inactive+ , countPieces , endGame- , winnerColor- --, swapBoard- --, swapBoardTree- , nextCaptureMoves- , nextStackingMoves- --, nextTurns+ , winner+ , swapBoard+ , captureMoves + , stackingMoves , nextMoves , countStacks+ , sumHeights+ , maxHeights , sixLines- , atPosition , emptyBoard , startingBoard , randomBoard , randomBoardIO- , showTurn , showMove , applyMove- , applyTurn+ , applyMoveSkip , positions- -- , shuffle- , infinity+ , zoneOfControl ) where import Data.List-import Data.IntMap (IntMap, (!))-import qualified Data.IntMap as IntMap+import Data.Map (Map, (!))+import qualified Data.Map as Map import System.Random-import Control.Monad (mplus)-import Test.QuickCheck+import Control.Monad (liftM,mplus) --- | The board state--- | current turn, active player pieces, other player pieces-data Board - = Board { playerColor :: !Bool, -- next to play (True=White, False=Black)- move :: !Int, -- first or second move of a turn- active :: HalfBoard, -- active player's pieces- inactive :: HalfBoard -- inactive player's pieces- } deriving (Eq, Show, Read) --- | A Half-board maps (unboxed) positions to pieces -type HalfBoard = IntMap Piece +-- | player colors+data Color = White | Black + deriving (Eq,Show,Enum,Read) --- | The three types of pieces+-- | the inverse color+invert :: Color -> Color+invert White = Black+invert Black = White++-- | The three piece types -- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts.-data Type = Tzaar | Tzarra | Tott +data Kind = Tzaar | Tzarra | Tott deriving (Eq, Ord, Show, Read) --- | the type of a piece, and the level of the stack (starting with 1).-type Piece = (Type,Int)+-- | A piece stack: color, kind and height (starting at 1).+type Piece = (Color, Kind, Int) +color :: Piece -> Color+color (c, _, _) = c++kind :: Piece -> Kind+kind (_, k, _)= k++height :: Piece -> Int+height (_, _, h)= h++ -- | Algebraic board positions. Letters left to right, numbers bottom to top. -- | Column E has the hole in the middle.-data APosition+data Position = A1 | A2 | A3 | A4 | A5 | B1 | B2 | B3 | B4 | B5 | B6 | C1 | C2 | C3 | C4 | C5 | C6 | C7@@ -96,316 +86,273 @@ | I1 | I2 | I3 | I4 | I5 deriving (Eq, Ord, Enum, Bounded, Show, Read) --- | "Unboxed" integer board positions-type Position = Int +-- | List of all positions (for enumeration)+positions :: [Position]+positions = [minBound .. maxBound] --- converto to/from algebraic positions-fromAPos :: APosition -> Position-fromAPos = fromEnum +-- | A mapping from positions to pieces +type PieceMap = Map Position Piece -toAPos :: Position -> APosition-toAPos = toEnum +-- | The board state+-- | current turn, active player pieces, other player pieces+data Board + = Board { active :: !Color, -- player to move next + move :: !Int, -- total move count+ pieces :: PieceMap, -- map positions to pieces+ activeCounts :: [Int], -- active player counts+ inactiveCounts :: [Int], -- inactive player counts+ activeHeights :: [Int],+ inactiveHeights :: [Int]+ } deriving (Eq, Show, Read) --- | A move is a pair of positions, for either capturing or stacking.--- type Move = (Position, Position)-data Move = Capture !Position !Position -- from, to- | Stack !Position !Position -- only as second move- | Pass -- only as second move- deriving (Eq, Show, Read) --- | A complete turn is a pair of moves-type Turn = (Move, Move)+-- | initialize a board from a list of piece & positions+initBoard :: [(Position,Piece)] -> Board+initBoard assocs+ = let ps = Map.fromList assocs+ in Board { active=White, move=0, pieces=ps,+ activeCounts=countStacks White ps,+ inactiveCounts=countStacks Black ps,+ activeHeights=sumHeights White ps,+ inactiveHeights=sumHeights Black ps + }+ +inactive :: Board -> Color+inactive = invert . active --- | A game tree with nodes s and moves m-data GameTree s m = GameTree s [(m, GameTree s m)] - deriving Show+-- | A move is either a capture, a stacking or a pass+-- "Skip" is a dummy move to alternate players in a turn+data Move = Capture !Position !Position -- origin and destination positions+ | Stack !Position !Position + | Pass + | Skip+ deriving (Eq, Show, Read) --- | auxiliary functions over game trees--- | apply a function to each node-mapTree :: (a->b) -> GameTree a m -> GameTree b m-mapTree f (GameTree x branches) - = GameTree (f x) [(m,mapTree f t) | (m,t)<-branches] --- | apply a function to each edge-mapTree' :: (a->b) -> GameTree s a -> GameTree s b-mapTree' f (GameTree x branches) - = GameTree x [(f m,mapTree' f t) | (m,t)<-branches]+showMove :: Move -> String+showMove (Capture a b) = show a ++ "x" ++ show b+showMove (Stack a b) = show a ++ "-" ++ show b+showMove Pass = "pass"+showMove Skip = "skip" --- | test for empty branches-isEmptyTree :: GameTree a m -> Bool-isEmptyTree (GameTree _ []) = True-isEmptyTree _ = False +-- | record to hold the game state+data Game = Game+ { human :: Color -- human plays white or black?+ , initial :: Board -- initial board+ , board :: Board -- current board+ , trail :: [Move] -- previous moves + , remain :: [Move] -- future moves+ } deriving (Eq,Show) --- | A game tree of boards -type BoardTree = GameTree Board Move --- | An AI strategy calculates the next turn from a board tree.-type Strategy = BoardTree -> StdGen -> (Turn, StdGen)+-- | initialize a game state+initGame :: Board -> Color -> Game+initGame b c = Game { human=c, initial=b, board=b, trail=[], remain=[] } --- | An AI player.-data AI = AI- { name :: String -- ^ Name of AI.- , description :: String -- ^ Brief description of AI.- , strategy :: Strategy -- ^ The strategy.- } +-- | Convert number of moves into number of turns +nthTurn :: Int -> Int+nthTurn 0 = 1+nthTurn m | m>0 = 2 + (m-1)`div`3 --- | List of all positions (for enumeration purposes)-positions :: [Position]-positions = map fromAPos [minBound .. maxBound]+nthMove :: Int -> Int+nthMove 0 = 1+nthMove m | m>0 = min (1+(m-1)`mod`3) 2 -showTurn :: Turn -> String-showTurn (a, b) = showMove a ++ " " ++ showMove b -showMove :: Move -> String-showMove (Capture a b) = show (toAPos a) ++ "x" ++ show (toAPos b)-showMove (Stack a b) = show (toAPos a) ++ "-" ++ show (toAPos b)-showMove Pass = "pass" +-- | number of pieces in a board+countPieces :: Board -> Int+countPieces board = Map.size (pieces board) --- | Projections to get the white & black half-boards-whites, blacks :: Board -> HalfBoard-whites board | playerColor board = active board- | otherwise = inactive board -blacks board | playerColor board = inactive board- | otherwise = active board --- | board size (number of pieces)-boardSize :: Board -> Int-boardSize board = IntMap.size (active board) + IntMap.size (inactive board)--{---- | next complete turns for the active player-nextTurns :: Board -> [Turn]-nextTurns board- | lostOneOfThree = []- | otherwise = captureCapture ++ captureStack ++ captureNothing- where- you = active board- captures = nextCaptureMoves board- bs = map (applyMove board) captures- captures' = map nextCaptureMoves bs- stackings = map nextStackingMoves bs- captureCapture = [ (m,m') | (m, ms)<-zip captures captures', m'<-ms]- captureStack = [ (m,m') | (m, ms)<-zip captures stackings, m'<-ms]- captureNothing = zip captures (repeat Pass)- lostOneOfThree = any (==0) (countStacks you) --}+-- | swap active player+-- this is used to analyse the board from the opponent's prespective+swapBoard :: Board -> Board+swapBoard b = b { active= invert (active b), + activeCounts = inactiveCounts b, + inactiveCounts = activeCounts b,+ activeHeights= inactiveHeights b,+ inactiveHeights = activeHeights b+ } -- | next moves for the active player nextMoves :: Board -> [Move]-nextMoves board - = case move board of- 1 -> nextCaptureMoves board- 2 -> nextCaptureMoves board ++ nextStackingMoves board ++ [Pass]+nextMoves b + | tzaars==0 || tzarras==0 || totts==0 = []+ | m == 0 = captureMoves b+ | otherwise + = case (m-1)`mod`3 of+ 0 -> captureMoves b -- first move+ 1 -> [Skip] -- dummy opponent move within a turn+ 2 -> Pass : (captureMoves b ++ stackingMoves b) -- second moves _ -> error "nextMoves: invalid board"+ where -- lostPieces = any (==0) (countStacks (active b) (pieces b)) + tzaars:tzarras:totts:_ = activeCounts b+ m = move b -- | next capture moves for the active player-nextCaptureMoves :: Board -> [Move]-nextCaptureMoves board = IntMap.foldWithKey forPiece [] you+captureMoves :: Board -> [Move]+captureMoves board = Map.foldrWithKey forPiece [] (pieces board) where- you = active board- who = playerColor board+ c = active board forPiece :: Position -> Piece -> [Move] -> [Move]- forPiece !p (_, !i) moves = foldl' downLine moves (sixLines p)+ forPiece !p (!c', _, !i) moves + | c==c' = foldl' downLine moves (sixLines p)+ | otherwise = moves where downLine :: [Move] -> [Position] -> [Move] downLine moves [] = moves downLine moves (q:ps) - = case atPosition board q of+ = case Map.lookup q (pieces board) of Nothing -> downLine moves ps - Just (who', (_, j)) | who/=who' && i>=j -> (Capture p q):moves+ Just (c', _, j) | c/=c' && i>=j -> (Capture p q):moves _ -> moves -{--nextCaptureMoves :: Board -> [Move]-nextCaptureMoves board@(Board who you _) = concatMap forPiece (IntMap.assocs you)- where- forPiece :: (Position,Piece) -> [Move]- forPiece (p, (_, i)) = concatMap downLine $ sixLines p- where- downLine :: [Position] -> [Move]- downLine [] = []- downLine (a:b) = case atPosition board a of- Nothing -> downLine b- Just (who', _) | who'==who -> []- Just (_, (_, j)) -> [(p, a) | i>=j]--} - -- | next stacking moves for the active player-nextStackingMoves :: Board -> [Move]-nextStackingMoves board = foldl' forPiece [] (IntMap.keys you)+stackingMoves :: Board -> [Move]+stackingMoves board = foldl' forPiece [] (Map.assocs (pieces board)) where - who = playerColor board- you = active board- (tzaars:tzarras:totts: _) = countStacks you- forPiece :: [Move] -> Position -> [Move]- forPiece moves p = foldl' downLine moves (sixLines p)+ c = active board+ tzaars:tzarras:totts:_ = activeCounts board+ forPiece :: [Move] -> (Position,Piece) -> [Move]+ forPiece moves (p,(c',_,_)) + | c==c' = foldl' downLine moves (sixLines p)+ | otherwise = moves where downLine :: [Move] -> [Position] -> [Move] downLine moves [] = moves downLine moves (q:ps) - = case atPosition board q of+ = case Map.lookup q (pieces board) of Nothing -> downLine moves ps- Just (who', _) | who'/=who -> moves- Just (_, (Tzaar,_)) | tzaars==1 -> moves- Just (_, (Tzarra,_)) | tzarras==1 -> moves- Just (_, (Tott, _)) | totts==1 -> moves- Just (_, _) -> (Stack p q) : moves+ Just (c', _, _) | c/=c' -> moves+ Just (_, Tzaar, _) | tzaars==1 -> moves+ Just (_, Tzarra, _) | tzarras==1 -> moves+ Just (_, Tott, _) | totts==1 -> moves+ Just (_, _, _) -> (Stack p q) : moves -{--nextStackingMoves :: Board -> [Move]-nextStackingMoves board@(you, _) = concatMap forPiece (IntMap.keys you)- where- (tzaars:tzarras:totts:_) = countStacks you- forPiece :: Position -> [Move]- forPiece p = concatMap downLine $ sixLines p- where- downLine :: [Position] -> [Move]- downLine [] = []- downLine (a:b) = case atPosition board a of- Nothing -> downLine b- Just (False, _) -> []- Just (True, (Tzaar,_)) | tzaars==1 -> []- Just (True, (Tzarra,_)) | tzarras==1 -> []- Just (True, (Tott, _)) | totts==1 -> []- Just (True, _) -> [(p, a)]--} + -- | count the number of stacks of each type in a half-board-countStacks :: HalfBoard -> [Int]-countStacks b - = count 0 0 0 (IntMap.elems b)+countStacks :: Color -> PieceMap -> [Int]+countStacks c pieces+ = count 0 0 0 (Map.elems pieces) where count :: Int -> Int -> Int -> [Piece] -> [Int]- count !x !y !z ((Tzaar,_):ps) = count (1+x) y z ps- count !x !y !z ((Tzarra,_):ps) = count x (1+y) z ps- count !x !y !z ((Tott,_):ps) = count x y (1+z) ps+ count !x !y !z ((c',Tzaar,_) : ps) | c==c' = count (1+x) y z ps+ count !x !y !z ((c',Tzarra,_) : ps) | c==c' = count x (1+y) z ps+ count !x !y !z ((c',Tott,_) : ps) | c==c' = count x y (1+z) ps+ count !x !y !z (_ : ps) = count x y z ps count !x !y !z [] = [x,y,z] +-- | sum of heights of stacks for each kind+sumHeights :: Color -> PieceMap -> [Int]+sumHeights c pieces = sum 0 0 0 (Map.elems pieces)+ where sum :: Int -> Int -> Int -> [Piece] -> [Int]+ sum !x !y !z ((c',Tzaar,!h):ps) | c==c' = sum (x+h) y z ps+ sum !x !y !z ((c',Tzarra,!h):ps) | c==c' = sum x (y+h) z ps+ sum !x !y !z ((c',Tott,!h):ps) | c==c' = sum x y (z+h) ps+ sum !x !y !z (_ : ps) = sum x y z ps+ sum !x !y !z [] = [x,y,z] +-- | maximum height for each kind+maxHeights :: Color -> PieceMap -> [Int] +maxHeights c pieces = maxh 0 0 0 (Map.elems pieces)+ where maxh :: Int -> Int -> Int -> [Piece] -> [Int]+ maxh !x !y !z ((c',Tzaar,!h):ps) | c==c' && h>x = maxh h y z ps+ maxh !x !y !z ((c',Tzarra,!h):ps) | c==c' && h>y= maxh x h z ps + maxh !x !y !z ((c',Tott,!h):ps) | c==c' && h>z = maxh x y h ps+ maxh !x !y !z (_ : ps) = maxh x y z ps+ maxh !x !y !z [] = [x,y,z]++ -- | The next board state after a move. -- | Assumes the move is valid.-applyMove :: Board -> Move -> Board-applyMove (Board who move you other) (Capture x y) - = makeBoard who (move+1) you' other'- where- (typeX, sizeX) = you!x- (_ , sizeY) = other!y- piece = (typeX, sizeX) - you' = IntMap.insert y piece (IntMap.delete x you)- other' = IntMap.delete y other--applyMove (Board who move you other) (Stack x y) - = makeBoard who (move+1) you' other+applyMove :: Move -> Board -> Board+applyMove (Capture x y) b + = b {active=invert (active b), + move=1+move b, + pieces= pieces', + activeCounts = counts', -- swap counts+ inactiveCounts= activeCounts b,+ activeHeights = heights', -- swap heights+ inactiveHeights = activeHeights b+ } where- (typeX, sizeX) = you!x- (_ , sizeY) = you!y- piece = (typeX, sizeX + sizeY)- you' = IntMap.insert y piece (IntMap.delete x you)--applyMove (Board who move you other) Pass - = makeBoard who (move+1) you other----- | check to swap board position if we are the end of a turn-makeBoard :: Bool -> Int -> HalfBoard -> HalfBoard -> Board-makeBoard who move you other- | move>2 = Board (not who) 1 other you- | otherwise= Board who move you other-+ pX = pieces b!x + (_, kindY, sizeY) = pieces b!y+ pieces' = Map.insert y pX (Map.delete x (pieces b))+ counts' = increment kindY (-1) (inactiveCounts b)+ heights'= increment kindY (-sizeY) (inactiveHeights b) -{--applyMove :: Board -> Move -> Board-applyMove board@(a, b) (x, y) - | whoX = (IntMap.insert y piece (IntMap.delete x a), b')- | otherwise = (a', IntMap.insert y piece (IntMap.delete x b))+applyMove (Stack x y) b + = b {active=invert (active b), + move=1+move b, + pieces=pieces',+ activeCounts = inactiveCounts b,+ inactiveCounts = counts',+ activeHeights = inactiveHeights b,+ inactiveHeights= heights'+ } where- whoX = IntMap.member x a- whoY = IntMap.member y a- (typeX, sizeX) | whoX = a!x- | otherwise = b!x- (_ , sizeY) | whoY = a!y- | otherwise = b!y- capture = whoX /= whoY- piece | capture = (typeX, sizeX) - | otherwise = (typeX, sizeX + sizeY)- a' | capture = IntMap.delete y a- | otherwise = a- b' | capture = IntMap.delete y b- | otherwise = b--}---- | The next board state after a complete turn. Assumes turn is valid.-applyTurn :: Board -> Turn -> Board-applyTurn board (m1,m2) = applyMove (applyMove board m1) m2-+ (colorX, kindX, sizeX) = pieces b!x+ (_, kindY, sizeY) = pieces b!y+ pieces' = Map.insert y (colorX,kindX,sizeX+sizeY) (Map.delete x (pieces b))+ counts' = increment kindY (-1) (activeCounts b)+ heights' | kindX==kindY = activeHeights b+ | otherwise = increment kindY (-sizeY) $ + increment kindX sizeY (activeHeights b)+ + +-- Pass & Skip have the same effect+applyMove _ b = b {active= invert (active b), + move=1+move b, + activeCounts= inactiveCounts b,+ inactiveCounts= activeCounts b,+ activeHeights= inactiveHeights b,+ inactiveHeights= activeHeights b+ } --- | Create a board tree from a mid-game position-boardTree :: Board -> BoardTree-boardTree b = GameTree b [(m, boardTree (applyMove b m)) | m<-nextMoves b]+-- | modify a counter+increment :: Kind -> Int -> [Int] -> [Int]+increment Tzaar i (tzaars:tzarras:totts:_) = (tzaars+i) : tzarras : totts : []+increment Tzarra i (tzaars:tzarras:totts:_) = tzaars : (tzarras+i) : totts : []+increment Tott i (tzaars:tzarras:totts:_) = tzaars : tzarras : (totts+i) : [] --- | Create a board tree from a start position--- | single captures only for the white's first turn-startBoardTree :: Board -> BoardTree-startBoardTree b = GameTree b [(m, GameTree b' [(Pass, boardTree b'')]) - | m<-nextCaptureMoves b, - let b'=applyMove b m, let b''=applyMove b' Pass]-+-- | apply one move and subsequent skip move+applyMoveSkip :: Move -> Board -> Board +applyMoveSkip m b + = case nextMoves b' of+ [Skip] -> applyMove Skip b' -- compulsory move+ _ -> b'+ where b' = applyMove m b --- | Check for an end of game position+ endGame :: Board -> Bool-endGame b = case move b of- 1 -> lostPieces || nullCaptures- 2 -> lostPieces'- _ -> error "endGame: invalid board"- where lostPieces = any (==0) (countStacks (active b))- lostPieces'= any (==0) (countStacks (inactive b))- nullCaptures = null (nextCaptureMoves b)---- | Determine the game winner; assumes endGame is True-winnerColor :: Board -> Bool-winnerColor b - = case move b of- 1 -> not (playerColor b)- 2 -> playerColor b- _ -> error "winnerColor: invalid board"--+endGame = null . nextMoves --- | Query the state of a board position.-atPosition :: Board -> Position -> Maybe (Bool,Piece)-atPosition board pos - = do { piece<-IntMap.lookup pos you- ; return (who,piece) - } `mplus`- do { piece<-IntMap.lookup pos other- ; return (not who,piece)- }- where who = playerColor board- you = active board- other = inactive board+winner :: Board -> Color+winner = invert . active -- | All the lines that form connected positions on the board. connectedPositions :: [[Position]] connectedPositions =- map (map fromAPos) [ [A1, A2, A3, A4, A5] , [B1, B2, B3, B4, B5, B6] , [C1, C2, C3, C4, C5, C6, C7]@@ -445,8 +392,8 @@ -- | The six lines traveling radially out from a single board position. -- | optimization: this map should be memoied lazily -sixLines_memo :: IntMap [[Position]] -- Map Position [[Position]]-sixLines_memo = IntMap.fromList [(p, radials p) | p<-positions]+sixLines_memo :: Map Position [[Position]] -- Map Position [[Position]]+sixLines_memo = Map.fromList [(p, radials p) | p<-positions] where radials p = [r | l<-threeLines p, r<-divide p l, not (null r)] divide a b = [reverse x, y] where (x, _:y) = span (/= a) b@@ -457,40 +404,41 @@ --- -- | An empty board emptyBoard :: Board-emptyBoard = Board True 1 (IntMap.empty) (IntMap.empty)-+emptyBoard = initBoard [] -- | The default (non-randomized, non-tournament) starting position. startingBoard :: Board-startingBoard = Board True 1 (IntMap.fromList whites) (IntMap.fromList blacks)+startingBoard = initBoard (whites ++ blacks) where- f t p = (p, (t, 1))- whites = map (f Tzaar) wTzaars ++ map (f Tzarra) wTzarras ++ map (f Tott) wTotts- blacks = map (f Tzaar) bTzaars ++ map (f Tzarra) bTzarras ++ map (f Tott) bTotts- wTzaars = map fromAPos [D3, E3, G4, G5, C5, D6]- wTzarras = map fromAPos [C2, D2, E2, H3, H4, H5, B5, C6, D7]- wTotts = map fromAPos [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]- bTzaars = map fromAPos [C3, C4, F3, G3, E6, F6]- bTzarras = map fromAPos [B2, B3, B4, F2, G2, H2, E7, F7, G6]- bTotts = map fromAPos [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, - G7, H6, D4, E5, F4]+ whites = [(p, (White,Tzaar,1)) | p<-wTzaars] ++ + [(p, (White,Tzarra,1)) | p<-wTzarras] ++ + [(p, (White,Tott,1)) | p<-wTotts]+ blacks = [(p, (Black,Tzaar,1)) | p<-bTzaars] ++ + [(p, (Black,Tzarra,1)) | p<-bTzarras] ++ + [(p, (Black,Tott,1)) | p<-bTotts]+ wTzaars = [D3, E3, G4, G5, C5, D6]+ wTzarras = [C2, D2, E2, H3, H4, H5, B5, C6, D7]+ wTotts = [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]+ bTzaars = [C3, C4, F3, G3, E6, F6]+ bTzarras = [B2, B3, B4, F2, G2, H2, E7, F7, G6]+ bTotts = [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, G7, H6, D4, E5, F4] -- | A randomized starting position randomBoard :: StdGen -> (Board, StdGen)-randomBoard rnd - = (Board True 1 (IntMap.fromList whites) (IntMap.fromList blacks), rnd')- where pieces = replicate 6 (Tzaar,1) ++- replicate 9 (Tzarra,1) ++- replicate 15 (Tott,1)+randomBoard rnd = (b, rnd')+ where b = initBoard (whites++blacks)+ ws = replicate 6 (White,Tzaar,1) +++ replicate 9 (White,Tzarra,1) +++ replicate 15 (White,Tott,1)+ bs = replicate 6 (Black,Tzaar,1) +++ replicate 9 (Black,Tzarra,1) +++ replicate 15 (Black,Tott,1) (positions',rnd') = shuffle rnd positions- whites = zip (take 30 positions') pieces- blacks = zip (drop 30 positions') pieces+ whites = zip (take 30 positions') ws+ blacks = zip (drop 30 positions') bs randomBoardIO :: IO Board randomBoardIO = do rnd <- getStdGen@@ -513,80 +461,41 @@ --- | maximum absolute value of static evaluation -infinity :: Int-infinity = 2^20 ---------------------------------------------------------------------------- | QuickCheck generators----------------------------------------------------------------------------- generators for board elements-instance Arbitrary Type 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 = [IntMap.delete p b | p<-IntMap.keys b] ++- [IntMap.insert p (t,h') b | - (p,(t,h))<-IntMap.assocs b, h'<-[1..h-1]]-+-- Estimate the zone of control of a player+-- i.e., the opponents' pieces that can be captured in two moves+zoneOfControl :: Color -> PieceMap -> PieceMap+zoneOfControl c pieces = Map.filterWithKey forPiece1 pieces+ where+ -- player's pieces that make at least one capture+ movable = Map.filterWithKey forPiece2 pieces + forPiece1, forPiece2 :: Position -> Piece -> Bool+ forPiece1 p (c', _, i) = c'/=c && or (map (downLine0 i) $ sixLines p)+ forPiece2 p (c',_, h) = c'==c && or (map (downLine2 h) $ sixLines p) --- a generator for boards--- size argument is a bound for the total number of pieces-genBoard :: Int -> Gen Board-genBoard n - = do ws <- genPieces n'- bs <- genPieces n'- ps <- genShuffle positions- who <- arbitrary- let whites = zip (take n' ps) ws- let blacks = zip (drop n' ps) bs- return $ Board who 1 (IntMap.fromList whites) (IntMap.fromList blacks)- where n' = min 30 (n`div`2)- - --- generate pieces-genPieces :: Int -> Gen [(Type,Int)]-genPieces n = do pieces <- genShuffle allpieces- k <- choose (1, n) -- number of stacking moves- hs <- genStacks k (replicate 30 1)- return $ take n $ zip pieces hs- where allpieces = replicate 6 Tzaar ++ - replicate 9 Tzarra ++ - replicate 15 Tott- --- same as above but ensures at least one piece of each kind (unused)-genPieces' n = do ps <- genPieces n- return ((Tzaar,1):(Tzarra,1):(Tott,1):ps)+ downLine0, downLine1, downLine2 :: Int -> [Position] -> Bool + downLine0 i [] = False+ downLine0 i (p:ps) + = case Map.lookup p pieces of+ Nothing -> downLine0 i ps+ Just (c', _, h) | c'==c -> + h>=i || (p`Map.member`movable && downLine1 i ps)+ Just (c', _, j) | c'/=c -> + or $ map (downLine1 (max i j)) $ sixLines p --- generate stack heights-genStacks 0 xs = return xs-genStacks _ [] = return []-genStacks _ [x] = return [x]-genStacks n xs = do h1 <- elements xs- let xs' = delete h1 xs- h2 <- elements xs'- genStacks (n-1) ((h1+h2) : delete h2 xs') + downLine1 i [] = False+ downLine1 i (p:ps) + = case Map.lookup p pieces of+ Nothing -> downLine1 i ps+ Just (c', _, h) -> c'==c && h>=i + downLine2 h [] = False+ downLine2 h (p:ps) + = case Map.lookup p pieces of+ Nothing -> downLine2 h ps+ Just (c', _, i) -> c'/=c && h>=i --- 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')
src/GUI.hs view
@@ -10,64 +10,55 @@ import Graphics.UI.Gtk.Glade import Graphics.Rendering.Cairo hiding (version) import Data.Function (on)-import qualified Data.IntMap as IntMap-import Data.IntMap (IntMap, (!))+import qualified Data.Map as Map+import Data.Map (Map, (!)) import Data.List (minimumBy, sortBy) import Control.Concurrent import Control.Monad (when, filterM, liftM, mplus, msum) import System.IO import System.FilePath import System.Random hiding (next)-import Var (Var)-import qualified Var as Var-import History (History)-import qualified History as History import Board import AI+import AI.Tree+import AI.Eval+-- import History (History)+-- import qualified History as History+import Serialize -- convert to/from XML +import Text.XML.Light -{---- | Piece colors-data PieceColor = White | Black - deriving (Eq,Show,Read)--} --- | Record to hold the current game state-data Game = Game- { board :: Board -- current board- , trail :: [Move] -- previous opponent moves - , state :: State -- selection stage- } deriving (Show, Read)- -- | Selection state-data State- = Start0 -- 1st turn - | Start1 Position -- 1st turn (2nd position)- | Wait0 -- Nth turn (1st position)- | Wait1 Position -- Nth turn (2nd position)- | Wait2 -- wait for AI opponent- | Finish -- game ended- deriving (Eq, Show, Read)+data State = Wait0 -- wait for human (1st position)+ | Wait1 Position -- wait for human (2nd position)+ | WaitAI (MVar Move) -- wait for AI + | Finish -- game ended --- | pair of current game and history-type GameHist = (Game,History Game)+-- | are we waiting for AI?+waitingAI :: State -> Bool+waitingAI (WaitAI _) = True+waitingAI _ = False --- | reference to a game and history-type GameRef = Var GameHist+-- | initial game & state, given a starting board and color+initGameState :: GUI -> Board -> Board.Color -> IO (Game,State)+initGameState gui b White = return (initGame b White, Wait0)+initGameState gui b Black = do ai <- getAI gui+ mvar <- newEmptyMVar+ forkOS $ runAI ai b mvar + return (initGame b Black, WaitAI mvar) --- | initialize a game, given a starting board-initGame :: Board -> Game-initGame b- = Game { board = b- , trail = []- , state = Start0- }+ --- | record to hold the GUI state +-- | record to hold references to the GUI widgets data GUI = GUI { mainwin :: Window, canvas :: DrawingArea,- aboutdiag :: AboutDialog,+ aboutdialog :: AboutDialog,+ startdialog :: Dialog,+ fixed_position :: CheckButton,+ play_white :: RadioButton,+ play_black :: RadioButton, statusbar:: Statusbar, progressbar:: ProgressBar, menu_item_new :: MenuItem,@@ -81,7 +72,8 @@ menu_item_draw_stacks :: CheckMenuItem, menu_item_show_heights :: CheckMenuItem, menu_item_show_moves :: CheckMenuItem,- menu_item_random_start :: CheckMenuItem,+ -- menu_item_random_start :: CheckMenuItem,+ -- menu_item_human :: CheckMenuItem, menu_item_ai_players :: [(RadioMenuItem, AI)], menu_item_about :: MenuItem, open_file_chooser :: FileChooserDialog,@@ -89,25 +81,8 @@ contextid :: ContextId } --- | main GUI entry point-gui :: FilePath -> IO ()-gui path = - do initGUI- gui <- loadGlade path- let g = initGame startingBoard- gameRef <- Var.new (g, History.init g)- connect_events gui gameRef - -- timer event for running other threads- timeoutAdd (yield >> return True) 50- -- timer event for updating the progress bar - timeoutAdd (Var.get gameRef >>= \(g,_) -> - updateProgress gui g >>- return True) 100- -- start event loop- mainGUI - -- | load GUI elements from XML glade file loadGlade :: FilePath -> IO GUI loadGlade path =@@ -116,7 +91,8 @@ Nothing -> error ("unable to open glade file " ++ show path) Just xml -> do mw <- xmlGetWidget xml castToWindow "mainwindow"- abd <- xmlGetWidget xml castToAboutDialog "aboutdialog1"+ abd <- xmlGetWidget xml castToAboutDialog "aboutdialog"+ std <- xmlGetWidget xml castToDialog "startdialog" fr <- xmlGetWidget xml castToFrame "frame1" sb <- xmlGetWidget xml castToStatusbar "statusbar" pb <- xmlGetWidget xml castToProgressBar "progressbar"@@ -130,7 +106,9 @@ mds<- xmlGetWidget xml castToCheckMenuItem "menu_item_draw_stacks" msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights" msm<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_moves"- mrs<- xmlGetWidget xml castToCheckMenuItem "menu_item_random_start"+ fixp <- xmlGetWidget xml castToCheckButton "fixedposition"+ playw <- xmlGetWidget xml castToRadioButton "playwhite"+ playb <- xmlGetWidget xml castToRadioButton "playblack" mab<- xmlGetWidget xml castToMenuItem "menu_item_about" -- fill in dynamic parts aboutDialogSetVersion abd (showVersion version) @@ -157,80 +135,101 @@ fileChooserAddFilter svf ff cid <- statusbarGetContextId sb "status" widgetShowAll mw- return (GUI mw bd abd sb pb mn mo ms mq mun mre mpa mds- msh msm mrs (zip (r:rs) (map snd aiPlayers)) mab opf svf cid)+ return (GUI mw bd abd std fixp playw playb sb pb mn mo ms mq mun mre mpa mds+ msh msm (zip (r:rs) (map snd aiPlayers)) mab opf svf cid) +-- | main GUI entry point+gui :: FilePath -> IO ()+gui path = + do initGUI+ gui <- loadGlade path+ b <- randomBoardIO + g <- initGameState gui b White -- human plays white by default+ gamev <- newMVar g+ connect_events gui gamev + -- timer event for updating the gui + timeoutAdd (updateGUI gui gamev >> return True) 100+ -- start GTK event loop+ mainGUI + -- | connect event handlers for GUI elements-connect_events gui gameRef +connect_events gui gamev = do onExpose (canvas gui) $ \x -> - do drawCanvas gui gameRef+ do drawCanvas gui gamev return (eventSent x) onButtonPress (canvas gui) $ \x -> do mp<-getPosition (canvas gui) (eventX x) (eventY x) case mp of Nothing -> return (eventSent x)- Just p -> do clickPosition gui gameRef p+ Just p -> do clickBoard gui gamev p return (eventSent x) onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_about gui) $ - do { dialogRun (aboutdiag gui)- ; widgetHide (aboutdiag gui)+ do { dialogRun (aboutdialog gui)+ ; widgetHide (aboutdialog gui) } onActivateLeaf (menu_item_quit gui) mainQuit- onActivateLeaf (menu_item_new gui) $ newGame gui gameRef + onActivateLeaf (menu_item_new gui) (newGame gui gamev) onActivateLeaf (menu_item_open gui) $ do { answer<-fileDialogRun (open_file_chooser gui) ; case answer of- Just path -> openGame gameRef path+ Just path -> do openGame gamev path+ redrawCanvas (canvas gui) Nothing -> return () } onActivateLeaf (menu_item_save gui) $ do { answer<-fileDialogRun (save_file_chooser gui) ; case answer of- Just path -> saveGame gameRef (replaceExtension path ".tza")+ Just path -> saveGame gamev (replaceExtension path ".tza") Nothing -> return () }- onActivateLeaf (menu_item_undo gui) $ moveUndo gameRef - onActivateLeaf (menu_item_redo gui) $ moveRedo gameRef -- onActivateLeaf (menu_item_pass gui) (movePass gui gameRef)+ onActivateLeaf (menu_item_undo gui) (undoMove gui gamev)+ onActivateLeaf (menu_item_redo gui) (redoMove gui gamev)+ onActivateLeaf (menu_item_pass gui) (passMove gui gamev) onActivateLeaf (menu_item_draw_stacks gui) $ redrawCanvas (canvas gui) onActivateLeaf (menu_item_show_heights gui) $ redrawCanvas (canvas gui) onActivateLeaf (menu_item_show_moves gui) $ redrawCanvas (canvas gui) - -- set callback to update the widgets and redraw the canvas- Var.watch gameRef $ \gh -> - do { updateWidgets gui gh- ; redrawCanvas (canvas gui)- } -- | start a new game-newGame :: GUI -> GameRef -> IO ()-newGame gui gameRef - = do r <- checkMenuItemGetActive (menu_item_random_start gui)- b <- if r then randomBoardIO else return startingBoard- Var.set gameRef (initGame b, History.init $ initGame b)+newGame :: GUI -> MVar (Game,State) -> IO ()+newGame gui gamev + = do answer <- dialogRun (startdialog gui)+ widgetHide (startdialog gui)+ case answer of+ ResponseUser 1 -> startgame+ _ -> return ()+ where startgame = do+ r <- toggleButtonGetActive (fixed_position gui)+ b <- if r then return startingBoard else randomBoardIO + r <- toggleButtonGetActive (play_white gui)+ let c = if r then White else Black+ modifyMVar_ gamev (\_ -> initGameState gui b c)+ redrawCanvas (canvas gui) -- | open a saved game-openGame :: GameRef -> FilePath -> IO ()-openGame gameRef filepath+openGame :: MVar (Game,State) -> FilePath -> IO ()+openGame gamev filepath = withFile filepath ReadMode $ \handle ->- do txt <- hGetContents handle - case reads txt of- ((gh,_): _) -> Var.set gameRef gh - _ -> putStrLn ("WARNING: couldn't parse game file " ++ show filepath)+ do txt <- hGetContents handle + case readXML txt of+ Nothing -> putStrLn ("ERROR: couldn't parse game file " ++ show filepath)+ Just g -> modifyMVar_ gamev $ \_ -> return (g,Wait0) + -- | write a game file-saveGame :: GameRef -> FilePath -> IO ()-saveGame gameRef filepath - = withFile filepath WriteMode $ \handle -> - Var.get gameRef >>= hPrint handle +saveGame :: MVar (Game,State) -> FilePath -> IO ()+saveGame gamev filepath + = do (g,_) <- readMVar gamev+ withFile filepath WriteMode $ + \handle -> hPutStr handle (showXML g) + fileDialogRun :: FileChooserDialog -> IO (Maybe FilePath) fileDialogRun w = do { r<-dialogRun w ; widgetHide w@@ -247,36 +246,46 @@ return $ snd (head (rs ++ error "getAI: no AI selected")) --- | update progress bar if we are waiting for AI-updateProgress :: GUI -> Game -> IO ()-updateProgress gui g- = case state g of- Wait2 -> progressBarPulse w- _ -> progressBarSetFraction w 0 - where w = progressbar gui- +-- | periodically update the GUI elements when waiting for AI+updateGUI :: GUI -> MVar (Game,State) -> IO ()+updateGUI gui gamev + = modifyMVar_ gamev $ \(g,s) -> + let m = nthMove (move (board g)) -- 1st or 2nd move of turn?+ in do { widgetSetSensitive (menu_item_undo gui) $+ not (waitingAI s) && not (null (trail g))+ ; widgetSetSensitive (menu_item_redo gui) $+ not (waitingAI s) && not (null (remain g))+ ; widgetSetSensitive (menu_item_pass gui) $ + not (waitingAI s) && m==2+ ; updateStatus gui (statusText g s)+ ; case s of + WaitAI mvar -> + do { reply <- tryTakeMVar mvar+ ; case reply of + Nothing -> do { progressBarPulse (progressbar gui)+ ; return (g,s) }+ Just m -> do { redrawCanvas (canvas gui)+ ; ai <- getAI gui+ ; makeMove ai m g }+ }+ _ -> do { progressBarSetFraction (progressbar gui) 0+ ; return (g,s) }+ } --- | update widgets sensitivity -updateWidgets :: GUI -> GameHist -> IO ()-updateWidgets gui (g,h)- = do { widgetSetSensitive (menu_item_undo gui) $- s/=Wait2 && not (History.atStart h)- ; widgetSetSensitive (menu_item_redo gui) $- s/=Wait2 && not (History.atEnd h)- ; widgetSetSensitive (menu_item_pass gui) $ - s==Wait0 && move b==2- ; updateStatus gui msg- }- where b = board g- s = state g- color = if playerColor b then "White" else "Black"- msg = case s of- Finish -> if winnerColor b then "White wins" else "Black wins" - Wait2 -> "Thinking..."- -- 2 moves per turn after the 1st move- _ -> concat [color, " (turn ", show (1+History.position h`div`2),- ", move ", show (move b), ")"] ++statusText :: Game -> State -> String+statusText g s+ = let b = board g + n = move b + msg = "Turn " ++ show (nthTurn n) ++ ", move " ++ show (nthMove n) ++ ": " + in case s of + Finish -> show (winner b) ++ " wins."+ WaitAI _ -> msg ++ show (active b) ++ " thinking..."+ _ -> msg ++ show (active b) ++ " to play." + ++ -- | replace the status message updateStatus :: GUI -> String -> IO () updateStatus gui txt@@ -285,100 +294,109 @@ id = contextid gui -notNull :: [a] -> Bool-notNull = not . null-- -- | pass the 2nd move of a turn-movePass :: GUI -> GameRef -> IO ()-movePass gui gameRef - = do (g,h) <- Var.get gameRef- let b = board g- case state g of- Wait0 | move b==2 -> - dispatch gui gameRef (makeMove Pass g) h- _ -> return ()+passMove :: GUI -> MVar (Game,State) -> IO ()+passMove gui gamev + = modifyMVar_ gamev $ + \(g,s) -> + if human g == active (board g) then -- human to play?+ let moves = nextMoves (board g)+ in case s of+ Wait0 | Pass`elem`moves -> + do ai <- getAI gui+ redrawCanvas (canvas gui) + makeMove ai Pass g+ _ -> return (g,s)+ else return (g,s) -moveUndo :: GameRef -> IO ()-moveUndo gameRef - = do (_,h) <- Var.get gameRef- when (not $ History.atStart h) $- let h' = History.previous h- in Var.set gameRef (History.get h', h') -moveRedo :: GameRef -> IO ()-moveRedo gameRef - = do (_,h) <- Var.get gameRef- when (not $ History.atEnd h) $- let h' = History.next h- in Var.set gameRef (History.get h', h')+-- | undo/redo move history navigation+undoMove :: GUI -> MVar (Game,State) -> IO ()+undoMove gui gamev + = modifyMVar_ gamev $ \(g,s) ->+ let ms = trail g + in case ms of + [] -> return (g,s)+ (m:ms') -> + let b'= foldr applyMoveSkip (initial g) ms'+ s'= if endGame b' then Finish else Wait0+ in do redrawCanvas (canvas gui)+ return (g {board=b', trail=ms', remain=m:remain g},s') +redoMove :: GUI -> MVar (Game,State) -> IO ()+redoMove gui gamev + = modifyMVar_ gamev $ \(g,s) ->+ let ms = remain g + in case ms of + [] -> return (g,s)+ (m:ms') -> + let b' = applyMoveSkip m (board g)+ s' = if endGame b' then Finish else Wait0+ in do redrawCanvas (canvas gui)+ return (g {board=b', trail=m:trail g, remain=ms'},s') + -- | handle a button click on a board position-clickPosition :: GUI -> GameRef -> Position -> IO ()-clickPosition gui gameRef p- = do (g,h) <- Var.get gameRef- let moves = nextMoves (board g)- case state g of- Start0 | p`startMove`moves -> - Var.set gameRef (g {state=Start1 p}, h)- Start1 p' | p'==p -> - Var.set gameRef (g {state=Start0}, h)- Start1 p' | (Capture p' p)`elem`moves -> - dispatch gui gameRef - (makeMove Pass $ makeMove (Capture p' p) g) h- Wait0 | p`startMove`moves -> - Var.set gameRef (g {state=Wait1 p, trail=[]}, h)- Wait1 p' | p'==p -> - Var.set gameRef (g {state=Wait0}, h)- Wait1 p' | (Capture p' p)`elem`moves -> - dispatch gui gameRef (makeMove (Capture p' p) g) h- Wait1 p' | (Stack p' p)`elem`moves -> - dispatch gui gameRef (makeMove (Stack p' p) g) h- _ -> return ()+clickBoard :: GUI -> MVar (Game,State) -> Position -> IO ()+clickBoard gui gamev p+ = do { ai <- getAI gui+ ; modifyMVar_ gamev $ \(g,s) -> + if active (board g) == human g -- user's turn to play?+ then + let moves = nextMoves (board g) + in case s of+ Wait0 | p`prefix`moves -> return (g, Wait1 p)+ Wait1 p' | p'==p -> return (g, Wait0)+ Wait1 p' | (Capture p' p)`elem`moves -> + makeMove ai (Capture p' p) g+ Wait1 p' | (Stack p' p)`elem`moves -> + makeMove ai (Stack p' p) g+ _ -> return (g,s)+ else return (g,s)+ ; redrawCanvas (canvas gui)+ } + -- | check if we can start a move from a position-startMove :: Position -> [Move] -> Bool-startMove p moves+prefix :: Position -> [Move] -> Bool+prefix p moves = notNull [p' | Capture p' _<-moves, p'==p] || notNull [p' | Stack p' _<-moves, p'==p] --- | dispatch a move -dispatch :: GUI -> GameRef -> Game -> History Game -> IO ()-dispatch gui gameRef g h- = case state g of- Wait0 -> Var.set gameRef (g, History.record g' h)- Finish -> Var.set gameRef (g, History.record g' h)- Wait2 -> Var.set gameRef (g,h) >> - forkIO runAI >> - return ()- _ -> Var.set gameRef (g,h)- where - g' = g { trail=[] }- -- run the AI player asynchronously - runAI = do { rnd <- getStdGen- ; ai <- getAI gui- ; let b = board g- ; let ((m1,m2), rnd') = strategy ai (boardTree b) rnd- ; setStdGen rnd'- ; let g' = makeMove m2 $ makeMove m1 $ g { trail=[] }- -- force evaluation in this thread- ; m1 `seq` m2 `seq` - Var.set gameRef (g', History.record g' h)- }+notNull :: [a] -> Bool+notNull = not . null -makeMove :: Move -> Game -> Game-makeMove m g = Game { board=b', trail=m:trail g, state=state' }- where - b' = applyMove (board g) m- state' | endGame b' = Finish -- game ended- | playerColor b' = Wait0 -- human to play- | otherwise = Wait2 -- opponent to play+-- | update game state with a move+-- forks a separate thread for the AI player+makeMove :: AI -> Move -> Game -> IO (Game,State)+makeMove ai m g+ | endGame b' = return (g',Finish)+ | active b' == human g = return (g',Wait0)+ | otherwise = + do { mvar <- newEmptyMVar+ ; forkOS $ runAI ai b' mvar + ; return (g',WaitAI mvar)+ }+ where b' = applyMoveSkip m (board g)+ g' = g {board=b', trail=m:trail g, remain=[]}+ + +-- | separate thread for the AI opponent+runAI :: AI -> Board -> MVar Move -> IO ()+runAI ai b mvar+ = do { threadDelay (200*1000) -- short delay to allow GUI redraw+ ; rnd <- getStdGen+ ; let (score, m, rnd') = strategy ai (boardTree b) rnd+ ; setStdGen rnd'+ -- ; putStrLn ("AI move: "++show m ++ " score: " ++ show score)+ ; m `seq` putMVar mvar m+ } + --------------------------------------------------------------------------------- -- | drawing methods ---------------------------------------------------------------------------------@@ -386,65 +404,64 @@ redrawCanvas canvas = do (w,h)<-widgetGetSize canvas drawin <- widgetGetDrawWindow canvas- drawWindowInvalidateRect drawin (Rectangle 0 0 w h) False+ drawWindowInvalidateRect drawin (Rectangle 0 0 w h) False -- redraw the canvas using double-buffering-drawCanvas :: GUI -> GameRef -> IO ()-drawCanvas gui gameRef +drawCanvas :: GUI -> MVar (Game,State) -> IO ()+drawCanvas gui gamev = do b1 <- checkMenuItemGetActive (menu_item_show_heights gui) b2 <- checkMenuItemGetActive (menu_item_show_moves gui) b3 <- checkMenuItemGetActive (menu_item_draw_stacks gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui)- (g,_) <- Var.get gameRef+ (g,s) <- readMVar gamev renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp -> - do renderWith tmp (setTransform w h >> renderBoard b1 b2 b3 g)+ do renderWith tmp (setTransform w h >> renderBoard b1 b2 b3 g s) setSourceSurface tmp 0 0 paint --- render the board and pieces-renderBoard :: Bool -> Bool -> Bool -> Game -> Render ()-renderBoard showheights showmoves showstacks g- = do -- paint the background - boardBg >> paint- -- paint the playing area light gray- gray 0.9 >> polyLine (map fromAPos [A1, A5, E8, I5, I1, E1]) - >> closePath >> fill- -- repaint the center with background color- boardBg >> polyLine (map fromAPos [D4, D5, E5, F5, F4, E4]) - >> closePath >> fill- -- draw the grid and coordinates- renderGrid- -- draw the pieces & highlight selection- case state g of- Start0 -> pieces showheights showstacks b - Start1 p -> do highlight p - pieces showheights showstacks b - when showmoves $ mapM_ renderMove (targets p)- Wait0 -> do pieces showheights showstacks b- when showmoves $ mapM_ renderMove (trail g)- Wait1 p -> do highlight p - pieces showheights showstacks b- when showmoves $ mapM_ renderMove (targets p)- Wait2 -> do pieces showheights showstacks b- when showmoves $ mapM_ renderMove (trail g)- Finish -> do pieces showheights showstacks b- when showmoves $ mapM_ renderMove (trail g)- where b = board g- moves = nextMoves b- targets p = [m | m@(Capture p1 p2)<-moves, p1==p] ++ - [m | m@(Stack p1 p2)<-moves, p1==p]+-- | render the board and pieces+renderBoard :: Bool -> Bool -> Bool -> Game -> State -> Render ()+renderBoard showHeights showMoves showStacks g s+ = do boardBg >> paint -- paint the background + -- paint the playing area light gray+ gray 0.9 >> polyLine [A1, A5, E8, I5, I1, E1] >> closePath >> fill+ -- repaint the center with background color+ boardBg >> polyLine [D4, D5, E5, F5, F4, E4] >> closePath >> fill+ -- draw the grid and coordinates+ renderGrid+ -- draw the pieces & highlight selection+ case s of+ Wait0 -> do renderPieces showHeights showStacks b+ when showMoves $ mapM_ renderMove previous+ Wait1 p -> do highlight p + renderPieces showHeights showStacks b+ when showMoves $ + do mapM_ renderMove (targets p)+ mapM_ renderMove previous+ WaitAI _ -> do renderPieces showHeights showStacks b+ when showMoves $ mapM_ renderMove previous+ Finish -> do renderPieces showHeights showStacks b+ when showMoves $ mapM_ renderMove previous+ where b = board g+ moves = nextMoves b -- next available moves+ previous = take 2 (trail g) -- opponent's previous moves+ -- move targets from a position+ targets p = [m | m@(Capture p1 p2)<-moves, p1==p] ++ + [m | m@(Stack p1 p2)<-moves, p1==p] + renderMove :: Move -> Render ()-renderMove (Capture p1 p2) = do setSourceRGBA 1 0 0 0.7- arrowFromTo p1 p2-renderMove (Stack p1 p2) = do setSourceRGBA 0 0 1 0.7- arrowFromTo p1 p2+renderMove (Capture p1 p2) + = do { setSourceRGBA 1 0 0 0.7; arrowFromTo p1 p2 }+renderMove (Stack p1 p2) + = do { setSourceRGBA 0 0 1 0.7; arrowFromTo p1 p2 } renderMove Pass = return ()+renderMove Skip = return () arrowFromTo :: Position -> Position -> Render () arrowFromTo p1 p2 = do setLineWidth 10@@ -459,7 +476,7 @@ where (xstart,ystart) = screenCoordinate p1 (xend,yend) = screenCoordinate p2 angle = pi + atan2 (yend-ystart) (xend-xstart)- arrow_deg = pi/4+ arrow_deg = pi/6 arrow_len = 30 x0 = xend + arrow_len * cos arrow_deg * cos angle y0 = yend + arrow_len * cos arrow_deg * sin angle@@ -474,14 +491,14 @@ renderGrid :: Render () renderGrid = do gray 0 setLineWidth 1- sequence_ [lineFromTo (fromAPos p1) (fromAPos p2) | (p1,p2)<-lines] + sequence_ [lineFromTo p1 p2 | (p1,p2)<-lines] setFontSize 22 sequence_ [do uncurry moveTo $ tr (-10,60) $ screenCoordinate p- showText (show $ toAPos p) - | p<-map fromAPos [A1,B1,C1,D1,E1,F1,G1,H1,I1]]+ showText (show p) + | p<-[A1,B1,C1,D1,E1,F1,G1,H1,I1]] sequence_ [do uncurry moveTo $ tr (-10,-50) $ screenCoordinate p- showText (show $ toAPos p) - | p<-map fromAPos [A5, B6,C7,D8,E8,F8,G7,H6,I5]]+ showText (show p) + | p<-[A5, B6,C7,D8,E8,F8,G7,H6,I5]] where tr (dx,dy) (x,y) = (x+dx,y+dy) lineFromTo p1 p2 = do uncurry moveTo $ screenCoordinate p1 uncurry lineTo $ screenCoordinate p2@@ -531,45 +548,60 @@ -- render all pieces in the board-pieces :: Bool -> Bool -> Board -> Render ()-pieces showheights showstacks board +renderPieces :: Bool -> Bool -> Board -> Render ()+renderPieces showheights showstacks board = do setLineWidth 2- mapM_ (piece showheights showstacks) ps+ -- board pieces+ sequence_ [ renderStack showheights showstacks x y piece | + (pos,piece) <- assocs, let (x,y)= screenCoordinate pos] -- sort pieces by reverse position to draw from back to front- where ps = sortBy cmp $ - zip (repeat whiteColors) (IntMap.assocs (whites board)) ++- zip (repeat blackColors) (IntMap.assocs (blacks board))- cmp (_,(x,_)) (_,(y,_)) = compare y x+ where assocs = sortBy cmp $ Map.assocs (pieces board)+ cmp (x,_) (y,_) = compare y x+ -- captures = capturedPieces board+ -- whiteCaptures = [(White,k,n) | (White,k,n)<-captures]+ -- blackCaptures = [(Black,k,n) | (Black,k,n)<-captures]+ -- whitePos = [ (x,y) | x<-[-500, -450..], let y = -200]+ -- blackPos = [ (x,y) | x<-[-500, -450..], let y = 200] -piece :: Bool -> Bool -> (PieceColors,(Position,Piece))-> Render ()-piece showheight showstacks (cs,(p,(t,size))) - = do y<-stack size' yc +++-- | render a stack of pieces+renderStack :: Bool -> Bool -> Double -> Double -> Piece -> Render ()+renderStack showheight showstacks xc yc (c,t,size)+ = do stack size' yc when (showheight && size>1) $ -- show the height? do selectFontFace "sans-serif" FontSlantNormal FontWeightBold setFontSize 50 setSourceRGB 1 1 1 - showCenteredText (xc+2) (y+2) label+ showCenteredText (xc+2) (yt+2) label setSourceRGB 1 0 0 - showCenteredText xc y label+ showCenteredText xc yt label where label = show size size' = if showstacks then size else 1- (xc,yc)= screenCoordinate p- (chipColor, lineColor, crownColor) = cs- stack 0 y = case t of - Tott -> return y- Tzarra -> crownColor >> disc 0.4 xc y >> - return y- Tzaar -> crownColor >> disc 0.8 xc y >> - chipColor >> disc 0.6 xc y >>- crownColor >> disc 0.4 xc y >> - return y+ -- (xc,yc)= screenCoordinate p+ yt = yc - 10*fromIntegral (size'-1) stack n y - | n>0 = do chipColor >> disc 1 xc y- lineColor >> ring 1 xc y- stack (n-1) $ if n>1 then y-10 else y+ | n>1 = do renderPiece xc y c Tott+ stack (n-1) (y-10)+ | otherwise = renderPiece xc y c t +-- | render a single piece+renderPiece :: Double -> Double -> Board.Color -> Kind -> Render ()+renderPiece x y c k + = do { chipColor; disc 1 x y; + lineColor; ring 1 x y;+ case k of + Tzaar -> do {crownColor; disc 0.8 x y;+ chipColor; disc 0.6 x y;+ crownColor; disc 0.4 x y}+ Tzarra -> do { crownColor; disc 0.4 x y }+ Tott -> return ()+ } + where (chipColor, lineColor, crownColor) = renderColors c++ showCenteredText :: Double -> Double -> String -> Render () showCenteredText x y txt = do exts <- textExtents txt @@ -587,53 +619,37 @@ -- (chip color, line color, crown color)-{--pieceColors :: PieceColor -> (Render (), Render (), Render ())-pieceColors White = (setSourceRGB 1 1 1, - setSourceRGB 0 0 0, - setSourceRGB 0.35 0.25 0)-pieceColors Black = (setSourceRGB 0 0 0, +renderColors :: Board.Color -> (Render (), Render (), Render ())+renderColors Black = (setSourceRGB 0 0 0, setSourceRGB 1 1 1, setSourceRGB 0.75 0.75 0.75)--}--type PieceColors = (Render (), Render (), Render ())--blackColors, whiteColors :: PieceColors-blackColors = (setSourceRGB 0 0 0, - setSourceRGB 1 1 1,- setSourceRGB 0.75 0.75 0.75)-whiteColors = (setSourceRGB 1 1 1, - setSourceRGB 0 0 0, - setSourceRGB 0.35 0.25 0)+renderColors White = (setSourceRGB 1 1 1, + setSourceRGB 0 0 0, + setSourceRGB 0.35 0.25 0) --- convert a canvas coordinate to a board position+-- | convert a canvas coordinate to a board position getPosition :: DrawingArea -> Double -> Double -> IO (Maybe Position) getPosition canvas x y = do (w,h)<-widgetGetSize canvas drawin<- widgetGetDrawWindow canvas- (xu, yu)<- renderWithDrawable drawin (setTransform w h >> - deviceToUser x y)+ (xu, yu)<- renderWithDrawable drawin + (setTransform w h >> deviceToUser x y) let (p, d) = minimumBy (compare `on` snd) [(p, (xu - x')^2 + (yu - y')^2) - | (p, (x', y')) <- IntMap.assocs screenCoordinates ]+ | (p, (x', y')) <- Map.assocs screenCoordinates ] return (if d<900 then Just p else Nothing) ------ screen coordinate of a board position+-- | screen coordinate of a board position screenCoordinate :: Position -> (Double,Double) screenCoordinate p = screenCoordinates!p -screenCoordinates :: IntMap (Double,Double)+screenCoordinates :: Map Position (Double,Double) screenCoordinates - = IntMap.fromList $- map (\(p,q) -> (fromAPos p, q))+ = Map.fromList $ [ (A1, p (-4) (-2)) , (A2, p (-4) (-1)) , (A3, p (-4) ( 0))
− src/History.hs
@@ -1,67 +0,0 @@--- Module for undo/redo navigation ------ the history maintains a cursor in a sequence ------ pbv, 2011-module History where-import Prelude hiding (length)-import qualified Prelude (length)----- | data type for history-data History a = - History { back :: [a], - front :: [a]- } deriving (Eq, Show, Read)- --- | initialize history-init :: a -> History a -init x = History {back=[x], front=[]}---atStart :: History a -> Bool-atStart = singleton . back --singleton :: [a] -> Bool-singleton [_] = True-singleton _ = False--atEnd :: History a -> Bool-atEnd = null . front--length :: History a -> Int-length h = Prelude.length (back h) + Prelude.length (front h)--position :: History a -> Int-position h = Prelude.length (back h)----- | navigate backwards-previous :: History a -> History a-previous h- = case back h of - [x] -> h- (x:xs) -> History { back = xs, front = x:front h }---- | navigate forwards-next :: History a -> History a-next h- = case front h of - [] -> h- (x:xs) -> History { back = x:back h, front = xs }----- | record at the current point --- obliviates next entries-record :: a -> History a -> History a-record x h = History { back = x:back h, front = [] }---- | get the cursor value-get :: History a -> a-get h = case back h of- (x:_) -> x- [] -> error "History.get: no value"----
src/Main.hs view
@@ -5,6 +5,7 @@ import Paths_hstzaar import Board import AI+import AI.Tree import GUI import Tournament import Tests@@ -32,7 +33,7 @@ "number of matches (for AI tournaments)", Option ['d'] ["dir"] (ReqArg DataDir "DATADIR") "data directory",- Option ['T'] ["tests"] (NoArg RunTests) + Option ['t'] ["tests"] (NoArg RunTests) "run QuickCheck tests" ] @@ -61,7 +62,6 @@ process _ = return () - main :: IO () main = do argv<-getArgs (flags, argv')<- parseArgs argv@@ -73,9 +73,9 @@ case argv' of [] -> gui gladepath [a1,a2] | a1`elem`ais && a2`elem`ais-> - do let numboards = max 1 (numMatches`div`2)- rndgen <- getStdGen- let (boards, rnd) = randomBoards numboards rndgen+ do rnd <- getStdGen+ let (boards, rnd') = randomBoards numMatches rnd+ setStdGen rnd' playAIs (toAI a1) (toAI a2) boards rnd _ -> ioError $ userError $ usageInfo header options ++ footer where ais = map fst aiPlayers
+ src/Serialize.hs view
@@ -0,0 +1,133 @@+-- Serialization of Tzaar games to/from XML +-- Pedro Vasconcelos, 2012+module Serialize where+import Data.Version+import Paths_hstzaar(version)+import Data.Maybe+import Text.XML.Light+import qualified Data.Map as Map+import Board++-- | convertion to/from XML elements+class ToXML a where+ toXML :: a -> Element+ +class FromXML a where + fromXML :: Element -> Maybe a+++-- | wrapper for a piece together with a board position +newtype PosPiece = PosPiece (Position, Piece) + deriving (Eq,Show)++-- | wrapper for a list of moves from game start+newtype MoveList = MoveList [Move] deriving (Eq,Show)++-- | wrapper for numbered & labelled moves+newtype NumMove = NumMove (Int,Color,Move) deriving (Eq,Show)++instance Node PosPiece where+ node qn (PosPiece (pos,(c,k,h))) = add_attrs alist $ node qn ()+ where alist = [attr "color" (show c), + attr "kind" (show k),+ attr "height" (show h),+ attr "position" (show pos)]++instance Node Move where+ node qn m = node qn $ Text (cdata $ showMove m)++instance Node NumMove where+ node qn (NumMove (n,c,m)) = add_attrs alist $ node qn $ Text (cdata $ showMove m)+ where alist = [attr "num" (show n), attr "color" (show c)]++instance Node MoveList where+ node qn (MoveList ms) = node qn $ map (Elem . node (unqual "move")) nms+ where nms = map NumMove (zip3 [1..] cs ms)+ cs = White : cycle [Black,Black,White,White]+++instance Node Board where+ node qn b = node qn $ + map (Elem . node (unqual "piece") . PosPiece) $ + Map.assocs (pieces b)++instance Node Game where+ node qn g = add_attrs alist $ + node qn [Elem (node (unqual "board") (initial g)),+ Elem (node (unqual "moves") (MoveList ms))]+ where ms = reverse (trail g) ++ remain g -- all moves+ alist =[attr "version" (showVersion version),+ attr "human" (show (human g))]+++instance ToXML Game where+ toXML = node (unqual "hstzaar") ++instance FromXML Board where + fromXML el = return (initBoard assocs)+ where assocs = catMaybes+ [do { c<-readAttr (unqual "color") el' + ; k<-readAttr (unqual "kind") el'+ ; h<-readAttr (unqual "height") el'+ ; pos<-readAttr (unqual "position") el'+ ; return (pos,(c,k,h))+ } | el'<-findChildren (unqual "piece") el]+ ++instance FromXML MoveList where+ fromXML el = Just (MoveList moves)+ where moves = catMaybes + [ readMove (strContent el') + | el'<-findChildren (unqual "move") el]+++instance FromXML Game where+ fromXML el = do el1 <- findChild (unqual "board") el+ el2 <- findChild (unqual "moves") el+ c <- readAttr (unqual "human") el -- human player color+ b <- fromXML el1+ MoveList ms <- fromXML el2+ let g = initGame b c+ let b' = foldr applyMoveSkip b (reverse ms)+ return g { board=b', trail=reverse ms }+++showXML :: ToXML a => a -> String+showXML a = ppTopElement (toXML a)++readXML :: FromXML a => String -> Maybe a+readXML txt = parseXMLDoc txt >>= fromXML ++++-- | parse an attribute from an element+readAttr :: Read a => QName -> Element -> Maybe a +readAttr name el = do txt<-findAttr name el + case reads txt of+ [] -> Nothing+ (a,_):_ -> Just a+++readMove :: String -> Maybe Move+readMove [a,b,'x',c,d] = do (from,_) <- listToMaybe (reads [a,b])+ (to,_) <- listToMaybe (reads [c,d])+ return (Capture from to)+ +readMove [a,b,'-',c,d] = do (from,_) <- listToMaybe (reads [a,b])+ (to,_) <- listToMaybe (reads [c,d])+ return (Stack from to)+readMove "pass" = Just Pass +readMove "skip" = Just Skip+readMove _ = Nothing++++-- | make an attribute with an unqualified name+attr :: String -> String -> Attr+attr n = Attr (unqual n) ++-- | make a cdata from a string+cdata :: String -> CData+cdata txt = CData CDataText txt Nothing++
src/Tests.hs view
@@ -2,111 +2,267 @@ Quickcheck properties for board & AI code Pedro Vasconcelos, 2010, 2011 -}-module Tests (run_tests) where+module Tests where import Board -import AI.Minimax-import AI.Utils+import AI.Tree import AI.Eval-import Test.QuickCheck-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet+import AI.Minimax+import qualified Data.Map as Map+import qualified Data.Set as Set import List (delete, nub, sort)+import Control.Monad (liftM) +import Test.QuickCheck +------------------------------------------------------------------------+-- | QuickCheck generators+------------------------------------------------------------------------++-- generators for board elements+instance Arbitrary Color where+ arbitrary = elements [White, Black]++instance Arbitrary Kind where+ arbitrary = elements [Tzaar,Tzarra,Tott]+++-- default generator and counter-example shrinker for boards+instance Arbitrary Board where+ arbitrary = sized genBoard + +{-+shrink board+ = [board {active=you} | you<-shrinkHalf (active board)] +++ [board {inactive=other} | other<-shrinkHalf (inactive board)] ++-- helper function to shrink half-boards+-- first try to remove pieces, then reduce heights+shrinkHalf :: HalfBoard -> [HalfBoard]+shrinkHalf b = [Map.delete p b | p<-Map.keys b] +++ [Map.insert p (t,h') b | + (p,(t,h))<-Map.assocs b, h'<-[1..h-1]]+-}+++-- generator for boards+-- size argument is a bound for the total number of pieces+-- always generates board with the 3 kinds for each player+genBoard :: Int -> Gen Board+genBoard size + = do ws <- genStacks White n+ bs <- genStacks Black n+ ps <- genShuffle positions+ c <- arbitrary+ m <- choose (1, n)+ let whites = zip (take n ps) ws+ let blacks = zip (drop n ps) bs+ let pmap = Map.fromList (whites++blacks) + return Board { active = c+ , move = m+ , pieces = pmap+ , activeCounts = countStacks c pmap+ , inactiveCounts = countStacks (invert c) pmap+ , activeHeights = sumHeights c pmap+ , inactiveHeights= sumHeights (invert c) pmap+ } + where n = 3 `max` (size`div`2) `min` 30 -- between 3 and 30 stacks+ + +-- generate piece stacks+genStacks :: Color -> Int -> Gen [Piece]+genStacks c n + = do ps <- liftM ([Tzaar,Tzarra,Tott]++) (genShuffle pieces)+ hs <- sequence [choose (1,maxHeight) | _<-[1..n]]+ return (zip3 (repeat c) ps hs)+ where pieces = replicate 5 Tzaar ++ + replicate 8 Tzarra ++ + replicate 14 Tott+ maxHeight = 5+ ++-- generate random permutations of a list+genShuffle :: Eq a => [a] -> Gen [a]+genShuffle [] = return []+genShuffle xs = do x <- elements xs+ xs'<- genShuffle (delete x xs)+ return (x:xs')++ --------------------------------------------------------------------------- -- Quickcheck properties --------------------------------------------------------------------------- +-- properties of the game mechanics+ -- a capture reduces the number of pieces by one prop_capture_moves :: Board -> Bool prop_capture_moves b- = and [1+boardSize b' == boardSize b |- m<-nextCaptureMoves b, let b' = applyMove b m]+ = 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 [1+boardSize b' == boardSize b |- m<-nextStackingMoves b, let b' = applyMove b m]+ = 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--- 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]+ = and [ heights (pieces b) == heights (pieces b') + | m <- stackingMoves b, let b'=applyMove m b]+ where + c = active b -- the current player+ heights ps = sum [h | (c',_,h)<-Map.elems ps, c'==c] +-- stacking does not modify opponents pieces+prop_stacking_moves3 :: Board -> Bool+prop_stacking_moves3 b+ = and [ Map.filter (\p->color p==c') (pieces b') == + Map.filter (\p->color p==c') (pieces b)+ | m <- stackingMoves b, let b'=applyMove m b]+ where + c = active b -- the current player+ c'= invert c -- the other player ++prop_swap_swap :: Board -> Bool+prop_swap_swap b = swapBoard (swapBoard b) == b++prop_active_counts :: Board -> Bool+prop_active_counts b+ = and [activeCounts b' == countStacks (active b') (pieces b')+ | m<-nextMoves b, let b'=applyMove m b]+ +prop_inactive_counts :: Board -> Bool+prop_inactive_counts b+ = and [inactiveCounts b' == countStacks (inactive b') (pieces b')+ | m<-nextMoves b, let b'=applyMove m b]+ + ++prop_active_heights :: Board -> Bool+prop_active_heights b+ = and [activeHeights b' == sumHeights (active b') (pieces b')+ | m<-nextMoves b, let b'=applyMove m b]+ +prop_inactive_heights :: Board -> Bool+prop_inactive_heights b+ = and [inactiveHeights b' == sumHeights (inactive b') (pieces b')+ | m<-nextMoves b, let b'=applyMove m b]+ + ++-- correctness of the zone of control computation+-- the zone of control is the set of pieces+-- that can be captured in a turn (one or two moves)+prop_zoc_correct :: Board -> Bool+prop_zoc_correct b = pos == pos'+ where+ moves1 = captureMoves b+ moves2 = concat [captureMoves (swapBoard (applyMove m b)) | m<-moves1]+ pos = Set.fromList [dest | Capture _ dest<-(moves1++moves2)]+ pos'= Map.keysSet (zoneOfControl (active b) (pieces b))++ ------------------------------------------------------------------------------ some properties of the AI code+-- properties of the AI code --------------------------------------------------------------------------- +-- | a trace is a sequence of game positions +newtype Trace = Trace { unTrace :: [Board] } deriving Show --- upper and lower bounds for the evaluation function-prop_value_bounds :: Board -> Property-prop_value_bounds board- = not (active_lost board) && not (inactive_lost board) ==> abs value < infinity- where value = eval1 board+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 moves = return [b]+ | otherwise = do m <- elements moves+ let b' = applyMove m b+ bs <- genTrace b'+ return (b:bs)+ where moves = nextMoves b+ --- end game positions give plus/minus infinity scores-prop_inactive_lost :: Board -> Property-prop_inactive_lost b- = not (active_lost b) && inactive_lost b ==> eval1 b == infinity -prop_active_lost :: Board -> Property-prop_active_lost b- = not (inactive_lost b) && active_lost b ==> eval1 b == (-infinity)+-- | 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 :: Eval -> Trace -> Bool+prop_value_bounds eval (Trace bs)+ = let vs = map eval 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 -> Int -> Property-prop_alpha_beta npieces depth - = forAllShrink (resize npieces arbitrary) shrink $ - \b -> admissible b ==>- let bt = mkTree depth eval1 b- in negamax_ab (-infinity) infinity bt == negamax bt+prop_alpha_beta :: Int -> Board -> Bool+prop_alpha_beta d b + = let bt = pruneDepth d $ mapTree eval1 $ boardTree b+ in negamax_ab (-infinity) infinity bt == negamax bt -- correctness of alpha-beta minimax extended with principal variation -- parameters: number of pieces, pruning depth -prop_alpha_beta_pv :: Int -> Int -> Property-prop_alpha_beta_pv npieces depth - = forAllShrink (resize npieces arbitrary) shrink $ - \b -> admissible b ==> - let bt = mkTree depth eval1 b- (v,ms)= negamaxPV bt- (GameTree v' _) = foldl treeMove bt ms- in neg (length ms) v'==v- where neg n x | n`mod`4==0 = x- | n`mod`4==2 = -x+prop_alpha_beta_pv :: Int -> Board -> Bool+prop_alpha_beta_pv d b+ = let bt = pruneDepth d $ mapTree eval1 $ boardTree b+ (v,ms)= negamaxPV bt+ n = length ms + b' = foldl (flip applyMove) b ms+ v' = eval1 b'+ in (-1)^n * v' == v -mkTree :: Int -> EvalFunc -> Board -> GameTree Int Move-mkTree depth eval board = pruneDepth depth $ mapTree eval $ boardTree board +{-+-- 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 - --- 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 [dest | Capture _ dest<-(moves1++moves2)]- pos'= IntMap.keysSet (zoneOfControl b) +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@@ -114,7 +270,7 @@ active_lost, inactive_lost :: Board -> Bool active_lost b - = (move b==1 && null (nextCaptureMoves b)) || + = (move b==1 && null (captureMoves b)) || any (==0) (countStacks $ active b) inactive_lost b = any (==0) (countStacks $ inactive b)@@ -125,6 +281,10 @@ --pieceTypes b = length $ nub $ map fst $ IntMap.elems b ++-}++ -- run all tests run_tests :: IO () run_tests = mapM_ run_test all_tests@@ -133,23 +293,21 @@ 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_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_zoc_correct", quickCheck prop_zoc_correct)- --, ("prop_zoc_correct2", quickCheck prop_zoc_correct2)- , ("prop_alpha_beta 10 4",- quickCheck (prop_alpha_beta 10 4))- , ("prop_alpha_beta 10 6",- quickCheck (prop_alpha_beta 10 6))- , ("prop_alpha_beta_pv 10 4",- quickCheck (prop_alpha_beta_pv 10 4))- , ("prop_alpha_beta_pv 15 6",- quickCheck (prop_alpha_beta_pv 15 6))- , ("prop_alpha_beta_pv 20 4",- quickCheck (prop_alpha_beta_pv 20 4))+ , ("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)) ]+
src/Tournament.hs view
@@ -2,53 +2,54 @@ module Tournament where import Board+import AI.Tree 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 b rndgen - = playMatch' 1 (startBoardTree b) rndgen p1 p2--playMatch' :: Int -> BoardTree -> StdGen -> AI -> AI -> IO Int-playMatch' n bt@(GameTree b branches) rnd p1 p2- | endGame b = return (-1) -- p1 can't play, p2 wins- | 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' = boardTree (applyTurn b t) +-- result is 1 or -1 according to the winner+playMatch :: Board -> StdGen -> AI -> AI -> IO Int+playMatch b rnd p1 p2+ | null branches = return (-1) -- p1 can't play, p2 wins+ | otherwise = do putStrLn line+ liftM negate $ playMatch b' rnd' p2 p1+ where bt@(GameTree _ branches) = boardTree b+ (score, m, rnd') = strategy p1 bt rnd+ line = show (move b) ++ ". " ++ show (active b) ++ + " ("++name p1 ++ "):\t" ++ " " +++ showMove m ++ "\tscore: " ++ show score+ b' = applyMove m b -- compare two strategies on random boards-playAIs :: AI -> AI -> [Board] ->StdGen -> IO ()+playAIs :: AI -> AI -> [Board] -> StdGen -> IO () playAIs p1 p2 boards rnd - = do rs1<-sequence [do { header i- ; r<-playMatch p1 p2 b rnd- ; footer- ; return r } | (i,b)<-zip [1..] boards] - rs2<-sequence [do { header i- ; r<-playMatch p2 p1 b rnd- ; footer- ; return (-r) } | (i,b)<- zip [n+1..] boards]- let rs = rs1++rs2- let won = length [r | r<-rs, r>0]- let lost= length [r | r<-rs, r<0]+ = do rs<-sequence [do { header i+ ; r<-playMatch b rnd p1 p2+ ; hline+ ; r'<-playMatch b rnd p2 p1+ ; hline+ ; return (r-r') + } + | (i,b)<-zip [1..] boards] + let won = sum [r | r<-rs, r>0]+ let lost= - sum [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 '-')+ header i = putStrLn ("Match " ++ show i ++ "/" ++ show n)+ hline = putStrLn (replicate 70 '-') -- create random boards randomBoards :: Int -> StdGen -> ([Board], StdGen) randomBoards 0 rndgen = ([], rndgen)-randomBoards (n+1) rndgen = (b:bs, rndgen'')+randomBoards n rndgen + | n>0 = (b:bs, rndgen'') where (b, rndgen') = randomBoard rndgen- (bs, rndgen'') = randomBoards n rndgen'+ (bs, rndgen'') = randomBoards (n-1) rndgen'
− src/Var.hs
@@ -1,49 +0,0 @@--- State variables for IO refs--- Encapsulates mutable references with callback functions --- pbv, 2011-module Var- ( Var,- new, get, set, modify, watch- ) where--import Data.IORef---- a state variable is pair of mutable ref and mutable callback-data Var a = Var !(IORef a) !(IORef (a -> IO ()))---- make a new state var with given value and null callback-new :: a -> IO (Var a)-new v = do ref <- newIORef v- callback <- newIORef (\_ -> return ())- return (Var ref callback)---- assign to a state var-set :: Var a -> a -> IO ()-set (Var ref callback) v- = do writeIORef ref v- cb <- readIORef callback - cb v---- fetch the value of a state var-get :: Var a -> IO a-get (Var ref _) = readIORef ref---- update a state var using a pure function-modify :: Var a -> (a -> a) -> IO ()-modify (Var ref callback) f- = do modifyIORef ref f- v <- readIORef ref- cb <- readIORef callback- cb v---- modify the callback for a state var--- finishes executing the callback with current value-watch :: Var a -> (a -> IO ()) -> IO ()-watch (Var ref callback) cb - = do writeIORef callback cb- v <- readIORef ref- cb v-- --