diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -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 diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -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 . -author: Pedro Vasconcelos -maintainer: Pedro Vasconcelos +author: Pedro Vasconcelos +maintainer: Pedro Vasconcelos 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 diff --git a/hstzaar.glade b/hstzaar.glade --- a/hstzaar.glade +++ b/hstzaar.glade @@ -2,6 +2,71 @@ + + 5 + center + normal + center + HsTZAAR + 0.0 + Copyright (c) Tom Hawkins & Pedro Vasconcelos 2011 + 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. + + http://www.dcc.fc.up.pt/~pbv/stuff/hstzaar + +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. + + Pedro Vasconcelos <pbv@dcc.fc.up.pt>. +Based on the HTZAAR program by Tom Hawkins <tomhawkins.org>. + + + + True + 2 + + + + + + True + end + + + False + end + 0 + + + + + HsTZAAR 600 @@ -110,13 +175,6 @@ True - - True - Random start position - True - - - True Draw stacks @@ -143,7 +201,7 @@ True - _AI + _AI opponent True @@ -204,23 +262,27 @@ True - True - + True - end + 2 + False - 0 + 4 + 1 - + True - 2 + end - 1 + False + False + 2 + 2 @@ -232,61 +294,88 @@ - + 5 - center - normal - center - HsTZAAR - 0.0 - Copyright (c) Tom Hawkins & Pedro Vasconcelos 2011 - 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. - - http://www.dcc.fc.up.pt/~pbv/stuff/hstzaar - -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. - - Pedro Vasconcelos <pbv@dcc.fc.up.pt>. -Based on the HTZAAR program by Tom Hawkins <tomhawkins.org>. - + New game + False + True + True + dialog - + True 2 - + + Fixed start position + True + True + False + True + + + 0 + + + + Play White + True + True + False + True + True + playblack + + + 2 + + + + + Play Black + True + True + False + True + True + playwhite + + + 3 + + - + True - end + spread + + + Cancel + True + True + True + + + False + False + 0 + + + + + Start game + 1 + True + True + True + + + False + False + 1 + + False diff --git a/src/AI.hs b/src/AI.hs --- a/src/AI.hs +++ b/src/AI.hs @@ -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 - ) - } --} diff --git a/src/AI/Eval.hs b/src/AI/Eval.hs --- a/src/AI/Eval.hs +++ b/src/AI/Eval.hs @@ -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 diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs --- a/src/AI/Minimax.hs +++ b/src/AI/Minimax.hs @@ -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 + diff --git a/src/AI/Tree.hs b/src/AI/Tree.hs new file mode 100644 --- /dev/null +++ b/src/AI/Tree.hs @@ -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] +-} + + + + + + diff --git a/src/AI/Utils.hs b/src/AI/Utils.hs deleted file mode 100644 --- a/src/AI/Utils.hs +++ /dev/null @@ -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 - - - diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -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') diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -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)) diff --git a/src/History.hs b/src/History.hs deleted file mode 100644 --- a/src/History.hs +++ /dev/null @@ -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" - - - - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Serialize.hs b/src/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Serialize.hs @@ -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 + + diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -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)) ] + diff --git a/src/Tournament.hs b/src/Tournament.hs --- a/src/Tournament.hs +++ b/src/Tournament.hs @@ -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' diff --git a/src/Var.hs b/src/Var.hs deleted file mode 100644 --- a/src/Var.hs +++ /dev/null @@ -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 - - - -