diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) Pedro Vasconcelo 2010 +Copyright (c) Pedro Vasconcelos 2010 All rights reserved. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,89 +0,0 @@ -HsTZAAR -------- - -HsTZAAR is a computer program to play TZAAR, a 2-player abstract strategy -game designed by Kris Burm and the last game in the GIPF project. -HsTZAAR is written in Haskell and allows for local play against a computer AI; -it also provides a good interface for programmers to implement diferent -AI strategies. - -This program was based on the htzaar implementation by Tom Hawkins. -In 2010, I started experimenting with classical AI techniques for TZAAR -and implemented them on-top of htzaar; since the later package is longer -updated, I decided to start HsTZAAR. - -The main improvements so far are: - - * a better GUI using gtk2hs for widgets and cairo for high-quality - 2D board rendering. - * a better AI using minimax and alpha-beta prunning; it now plays at - a challenging level (at least for a beginner like myself). - -Requirements ------------- - -HsTZAAR requires a resonably recent GHC compiler (version 6.10.x or newer) -plus the gtk2hs, cairo and glade libraries. It is developed in Ubuntu -GNU/Linux system, and should compile and run fine on other Linuxes. -I also verified that it compiles under Mac OS X (snow leopard) and should -probabily do under Windows as well (but this was not tested). - -Compilation ------------ - -Using the Haskell Cabal tool (fetches the package and any dependencies, -builds and installs): - - $ cabal install hstzaar - -Alternatively, you can do the build manually from the source tarball: - -$ tar xvzf hstzaar-x.y.tar.gz -$ cd hstzaar-x.y -$ runhaskell Setup.hs configure -$ runhaskell Setup.hs build -$ runhaskell Setup.hs install - -AI strategies --------------- - -HsTZAAR implements a few AI strategies. - lame: selects a random valid move - greedy: selects the local best move by the static evaluation function - plyN: simple minimaxing to N-ply - dynN: greedy strategy for early game, then minimaxing N-ply for later game -All of the above will select a winning move or a move to prevent the -adversary from winning (if such moves are avaliable). - -Note that higher ply values can increase memory consumption dramatically -and do *not* necessarily play better! The default greedy strategy plays -well enough to challenge a beginner such as myself and run under 150Mb -resident space. - -Usage ------ - -Executing the binary starts the GUI interface for playing against an AI; -some extra options are controlled by command line arguments: - -hstzaar [OPTION..] [AI AI] where OPTIONS are - -s SEED --seed=SEED random number seed - -n N --matches=N number of matches (for AI tournaments) - -T --tests run QuickCheck tests - -Examples: - -1) Run a tournament between the greedy and ply2 strategies: - 10 matches (5 random boards, each strategy plays first white - then black, fixing the random seed for repeatebility): - - $ hstzaar -s0 -n10 greedy ply2 - -2) Run QuickCheck correctness tests (see source code for details on these): - - $ hstzaar --tests - - -Pedro Vasconcelos, 2010 -pbv@dcc.fc.up.pt - diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -1,3 +1,9 @@ +hstzaar 0.6 04/05/2011 +- improved AI by spliting turns into 2 game tree levels +- reduced heap memory residency +- removed AIs; minimax ply 2 is now faster and better than old greedy +- improved GUI to highlight opponents & next available moves + hstzaar 0.5 29/03/2011 - corrected error in minimax algorithm that made it worse than the greedy strategy - modified static evaluation function diff --git a/data/hstzaar.glade b/data/hstzaar.glade --- a/data/hstzaar.glade +++ b/data/hstzaar.glade @@ -1,4 +1,4 @@ - + @@ -9,7 +9,6 @@ True - vertical True @@ -129,6 +128,13 @@ True Show heights + True + + + + + True + Show available moves True diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -1,5 +1,5 @@ name: hstzaar -version: 0.5 +version: 0.6 category: Game @@ -25,12 +25,12 @@ data-files: data/hstzaar.glade extra-source-files: - RELEASE-NOTES README + RELEASE-NOTES executable hstzaar hs-source-dirs: src main-is: Main.hs - other-modules: GUI Board AI AI.Utils AI.Lame AI.Eval AI.Minimax Tournament Tests + other-modules: GUI StateVar Board AI AI.Utils AI.Lame AI.Eval AI.Minimax Tournament Tests build-depends: base >= 4 && < 5, haskell98, @@ -42,4 +42,3 @@ QuickCheck >= 2.1 ghc-prof-options: -prof -auto-all - diff --git a/src/AI.hs b/src/AI.hs --- a/src/AI.hs +++ b/src/AI.hs @@ -1,13 +1,33 @@ -- | Library of AI Players -module AI (ai_players) where +module AI (aiPlayers) where import Board +import AI.Utils import AI.Lame import AI.Minimax -- all AI players; default AI is the first one -ai_players :: [AI] -ai_players = [plyN n 5 | n<-[2,3,4,5,6]] ++ [greedy,lame] +aiPlayers :: [AI] +aiPlayers = [level0, level1, level2] +level0 = AI { name = "Level 0" + , description = "Randomly selects the next turn." + , strategy = lameStrategy + } + +level1 = AI { name = "Level 1" + , description = "Minimaxing alpha-beta depth 2" + , strategy = minimaxStrategy 2 + } + +level2 = AI { name = "Level 2" + , description = "Minimaxing alpha-beta depth 2-4" + , strategy = (withNPieces $ \numpieces -> + if numpieces>30 then + minimaxStrategy 4 + else + minimaxStrategy 2 + ) + } diff --git a/src/AI/Eval.hs b/src/AI/Eval.hs --- a/src/AI/Eval.hs +++ b/src/AI/Eval.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -- Static evaluation functions of board positions -module AI.Eval( static_eval +module AI.Eval( eval , zoneOfControl ) where @@ -8,35 +8,33 @@ import qualified Data.IntMap as IntMap import Debug.Trace --- | Static evaluation function of a position for the active player -static_eval :: Board -> Int -static_eval b - | least ==0 || null captures = -infinity - | least'==0 || null captures' = infinity - | otherwise = {- trace (unwords ["material=", show material, - "positional=", show positional, - "threats=", show threats]) $ -} +-- | Static evaluation of a position for the active player +eval :: Board -> Int +eval b + | any (==0) counts || (move b==1 && null captures) = -infinity + | any (==0) counts' = infinity + | otherwise = {- trace (unwords ["material=", show material, + "position=", show positional, + "threats=", show threats]) $ -} material + positional + threats where -- count stacks by piece kind for each player counts = countStacks (active b) counts'= countStacks (inactive b) - - -- least count of stacks by kind - least = minimum counts - least'= minimum counts' -- capture moves for each player captures = nextCaptureMoves b - captures'= nextCaptureMoves (swapBoard 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+1) | (c,h)<-zip counts heights] + material = sum [(mw*h)`div`(c+1) | (c,h)<-zip counts heights] - + sum [(mw*h)`div`(c+1) | (c,h)<-zip counts' heights'] - zoc = zoneOfControl b -- zone of control for the active player + zoc = zoneOfControl b -- zone of control for the active player zoc_heights = sumHeights zoc -- piece types in the zone of control -- positional score @@ -47,8 +45,8 @@ threats = sum [tw | (x,y)<-zip counts' zoc_counts, x<=min 2 y] -- scoreing weights coeficients - mw = 10 -- material - pw = 50 -- positional + mw = 100 -- material + pw = 50 -- positional tw = 1000 -- threats @@ -64,16 +62,7 @@ sum !x !y !z [] = [x,y,z] --- maximum heights of stacks for each kind -maxHeights :: HalfBoard -> [Int] -maxHeights b = maxh 0 0 0 (IntMap.elems b) - where maxh :: Int -> Int -> Int -> [Piece] -> [Int] - maxh !x !y !z ((Tzaar,h):ps) = maxh (x`max`h) y z ps - maxh !x !y !z ((Tzarra,h):ps) = maxh x (y`max`h) z ps - maxh !x !y !z ((Tott,h):ps) = maxh x y (z`max`h) ps - maxh !x !y !z [] = [x,y,z] - -- 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 @@ -82,7 +71,7 @@ where you = active board other = inactive board - who = whiteTurn board + who = player board -- white pieces that can make at least one capture captures = IntMap.filterWithKey forPiece2 you @@ -117,33 +106,3 @@ -{- ---- material-only evaluation ---------------------------------------------------------------------------------- -material_value :: Board -> Int -material_value b@(Board _ whites blacks) - | least==0 || null captures = -infinity - | least'==0 || null captures'= infinity - | otherwise = w1*least^2 + w2*tscore + w3*pscore + round (w4*sscore) - where - captures = nextCaptureMoves b - captures'= nextCaptureMoves (swapBoard b) - kinds = [IntMap.filter ((==t).fst) whites | t<-[Tzaar,Tzarra,Tott]] - kinds'= [IntMap.filter ((==t).fst) blacks | t<-[Tzaar,Tzarra,Tott]] - counts = map IntMap.size kinds -- stack count by kind - counts'= map IntMap.size kinds' -- stack count by kind - least = minimum counts -- least count of any kind - least' = minimum counts' -- least count of any kind - heights = map sumSquareHeights kinds -- sum of heights by kind - tallest = map maxHeights kinds -- tallest by kind - -- scores - tscore = sum (map (^2) tallest) - pscore = sum (zipWith (*) counts heights) - sscore :: Double - sscore = sum [fromIntegral (count-least)/fromIntegral (count+1) | count<-counts] - -- weights - w1 = 5 - w2 = 1 - w3 = 1 - w4 = 10 --} diff --git a/src/AI/Lame.hs b/src/AI/Lame.hs --- a/src/AI/Lame.hs +++ b/src/AI/Lame.hs @@ -1,35 +1,33 @@ -- | An example AI player. -module AI.Lame (lame) where +module AI.Lame(lameStrategy) where import System.Random - import AI.Utils import Board -lame :: AI -lame = AI - { name = "lame" - , description = "Randomly selects the next valid turn." - , strategy = (withPieces $ \n -> if n==60 then lameStrategy0 - else winOrPreventLoss lameStrategy - ) - } +-- randomly selects the next valid turn +lameStrategy :: Strategy +lameStrategy = withNPieces $ + \n -> if n==60 then lame0 else lameNext +-- | Starting move: capture only +lame0 :: Strategy +lame0 (GameTree _ branches) rnd = (turns !! i, rnd') + where + turns = [ (m1, Pass) | (m1, _) <- branches ] + (i, rnd') = randomR (0, length turns - 1) rnd + + -- | The lame strategy picks a valid turn at random. -- If a two-move turn is available, it picks one. (wow, pretty smart!) -lameStrategy :: Strategy -lameStrategy (GameTree _ branches) g = (turns !! i, g') +lameNext :: Strategy +lameNext (GameTree _ branches) rnd = (turns !! i, rnd') where - allTurns = fst $ unzip branches - goodTurns = [ (m1, Just m2) | (m1, Just m2) <- allTurns ] + allTurns = [ (m1,m2) | + (m1,GameTree _ branches')<-branches, + (m2, _) <- branches'] + goodTurns = [ (m1, m2) | (m1, m2) <- allTurns, m2/=Pass ] turns = if null goodTurns then allTurns else goodTurns - (i, g') = randomR (0, length turns - 1) g + (i, rnd') = randomR (0, length turns - 1) rnd --- starting move -lameStrategy0 :: Strategy -lameStrategy0 (GameTree _ branches) g = (turns !! i, g') - where - allTurns = fst $ unzip branches - turns = [ (m1, Nothing) | (m1, Nothing) <- allTurns ] - (i, g') = randomR (0, length turns - 1) g diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs --- a/src/AI/Minimax.hs +++ b/src/AI/Minimax.hs @@ -1,128 +1,102 @@ -module AI.Minimax( greedy - , plyN +module AI.Minimax( minimaxStrategy , minimax , minimax_ab - , minimaxMove - , minimaxMove_ab + , minimaxPV ) where -import Data.List (sort, sortBy, maximumBy, minimumBy) +--import Data.List (sort, sortBy, maximumBy, minimumBy) import AI.Utils import AI.Eval import Board -import Debug.Trace --- greedy AI player -greedy :: AI -greedy = AI { name = "greedy" - , description = "Maximize the static evaluation function" - , strategy = (withPieces $ \n -> - if n==60 then singleCaptures greedyStrategy - else winOrPreventLoss $ - -- nubDoubleCaptures $ - dontPass greedyStrategy - ) - } - --- greedy strategy --- lookup one move ahed and choose the highest static evaluation score -greedyStrategy :: Strategy -greedyStrategy (GameTree _ branches) rndgen - | null branches = error "greedyStrategy: empty branches" - | otherwise = (bestmove, rndgen) - where - choices = [(m, score t) | (m,t)<-branches] - (bestmove,bestscore) = minimumBy cmp choices - cmp (_,x) (_,y) = compare x y - score (GameTree b _) = static_eval b -- valued the opponent - - - --- minimaxing AI player with alpha-beta prunning and fixed depth and breadth -plyN :: Int -> Int -> AI -plyN depth breadth - = AI { name = "ply_" ++ show depth ++ "_" ++ show breadth - , description = "Minimaxing with depth " ++ show depth ++ - " and breadth " ++ show breadth - , strategy = (withPieces $ \n -> - if n==60 then singleCaptures greedyStrategy - else winOrPreventLoss $ - --nubDoubleCaptures $ - dontPass $ - minimaxStrategy depth breadth - ) +{- +-- | Minimaxing AI player with fixed depth +fixed_ply :: Int -> AI +fixed_ply depth + = AI { name = "ply_" ++ show depth + , description = "Minimaxing with limit depth " ++ show depth + , strategy = minimaxStrategy depth } -{- -- dynamic strategy --- use greedy algorithm for opening then switching to maximaxing -dynamic :: Int -> AI -dynamic n = AI { name = "dyn" ++ show n - , description = "Minimax with dynamic depth " ++ show n - , strategy = (ifPieces (==60) - greedyStrategy - (winOrPreventLoss - (singleCaptures - (ifPieces (>40) - greedyStrategy - (minimaxStrategy n 5) - ) - ) - ) - ) - } +-- increase minimax depth as the game progress +dynamic_ply :: Int -> Int -> AI +dynamic_ply d1 d2 = AI { name = "dyn" ++ show d1 ++ "_" ++ show d2 + , description = "Minimax with dynamic depth " ++ show d1 ++ "," ++ show d2 + , strategy = (withNPieces $ \numpieces -> + if numpieces>30 then + minimaxStrategy d1 + else + minimaxStrategy d2 + ) + } -} -- Minimaxing strategy with alpha-beta and static prunning --- n is the ply depth, m is the tree breadth -minimaxStrategy :: Int -> Int -> Strategy -minimaxStrategy n m (GameTree _ []) rndgen - = error "minimaxStrategy: empty tree" -minimaxStrategy n m bt rndgen - = (bestmove, rndgen) - where (bestmove,bestscore) = minimaxMove_ab (-infinity) infinity bt' +minimaxStrategy :: Int -> Strategy +minimaxStrategy n bt rndgen + | endGameTree bt = error "minimaxStrategy: end of game" +minimaxStrategy n bt rndgen = ((m1,m2), rndgen) + where (bestscore, m1:m2:_) = minimaxPV bt' bt' = pruneDepth n $ -- ^ prune to depth `n' - pruneBreadth m $ -- ^ cut to breadth `m' - lowFirst $ -- ^ order moves acording to static valuation - mapTree static_eval bt -- ^ apply static evaluation function + mapTree eval bt -- ^ apply static evaluation function -- Naive minimax algorithm (not used) --- nodes should contain the static evaluation scores -minimax :: (Num a, Ord a) => GameTree a m -> a -minimax (GameTree x []) = x -minimax (GameTree _ branches) = - minimum (map (minimax.snd) branches) +-- nodes values are static evaluation scores +minimax :: (Num a, Ord a) => GameTree a m -> a +minimax = minimax' 0 --- auxiliary function that returns the best first move -minimaxMove :: (Num a, Ord a) => GameTree a m -> (m,a) -minimaxMove (GameTree _ branches) = (m,x) - where (m,x) = maximumBy cmp [(m, -minimax t) | (m,t)<-branches] - cmp (_, x) (_, y) = compare x y +minimax' :: (Num a, Ord a) => Int -> GameTree a m -> a +minimax' depth (GameTree x []) = x +minimax' depth (GameTree _ branches) + | odd depth = - minimum vs + | otherwise = maximum vs + where vs = map (minimax' (1+depth) . snd) branches -- Minimax with alpha-beta prunning -minimax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a -minimax_ab a b (GameTree x []) = a `max` x `min` b -minimax_ab a b (GameTree _ branches) = cmx a b (map snd branches) +minimax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a +minimax_ab = minimax_ab' 0 + +minimax_ab' :: (Num a, Ord a) => Int -> a -> a -> GameTree a m -> a +minimax_ab' depth a b (GameTree x []) = a `max` x `min` b +minimax_ab' depth a b (GameTree _ branches) = cmx a b (map snd branches) where cmx a b [] = a - cmx a b (t:ts) | a'>=b = b + cmx a b (t:ts) | a'==b = a' | otherwise = cmx a' b ts - where a' = - minimax_ab (-b) (-a) t + where a' | odd depth = -minimax_ab' (1+depth) (-b) (-a) t + | otherwise = minimax_ab' (1+depth) a b t +-- Minimax with alpha-beta pruning +-- extended to obtain both score and principal variation +data PV = PV !Int [Move] deriving (Show) +instance Eq PV where + (PV x _) == (PV y _) = x==y --- This variant also returns the best initial move -minimaxMove_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> (m,a) -minimaxMove_ab a b (GameTree _ []) = error "minimaxMove_ab: empty tree" -minimaxMove_ab a b (GameTree _ branches@((m,_):_)) = cmx m a b branches - where cmx m a b [] = (m,a) - cmx m a b ((m',t):branches) - | a'>=b = (m',b) - | otherwise = cmx m' a' b branches - where a' = - minimax_ab (-b) (-a) t +instance Ord PV where + compare (PV x _) (PV y _) = compare x y +negatePV :: PV -> PV +negatePV (PV x ms) = PV (-x) ms +minimaxPV :: GameTree Int Move -> (Int, [Move]) +minimaxPV bt + = case minimaxPV_ab' 0 [] (PV (-infinity-1) []) (PV (infinity+1) []) bt of + PV v ms -> (v,ms) + +-- first parameter determines if we negate children scores +-- minimaxPV_ab' :: (Num a, Ord a) => Int -> [m] -> a -> a -> GameTree a m -> (a, [m]) +minimaxPV_ab' depth ms a b (GameTree x []) = a `max` PV x (reverse ms) `min` b +minimaxPV_ab' depth 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'| odd depth = negatePV $ minimaxPV_ab' (1+depth) (m:ms) (negatePV b) (negatePV a) t + | otherwise = minimaxPV_ab' (1+depth) (m:ms) a b t diff --git a/src/AI/Utils.hs b/src/AI/Utils.hs --- a/src/AI/Utils.hs +++ b/src/AI/Utils.hs @@ -3,8 +3,8 @@ ( winOrPreventLoss , pruneDepth, pruneBreadth , highFirst, lowFirst - , withPieces, withBoard - , dontPass, singleCaptures, nubDoubleCaptures + , withNPieces, withBoard + , dontPass, singleCaptures --, nubDoubleCaptures ) where @@ -15,27 +15,25 @@ --- order subtrees with ascending or descending order +-- order subtrees with ascending or descending order of static evaluation highFirst, lowFirst :: GameTree Int m -> GameTree Int m highFirst (GameTree x branches) - = GameTree x branches' - where branches' = [(m,lowFirst t) | (m,t)<-sortBy cmp branches] - cmp (_,x) (_,y) = compare (value y) (value x) + = 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 branches' - where branches' = [(m,highFirst t) | (m,t)<-sortBy cmp branches] - cmp (_,x) (_, y) = compare (value x) (value y) + = 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 0 (GameTree x branches) = GameTree x [] -pruneDepth (n+1) (GameTree x branches) - = GameTree x [(m,pruneDepth n t) | (m,t)<-branches] +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 @@ -48,21 +46,18 @@ withBoard :: (Board -> Strategy) -> Strategy withBoard f t@(GameTree b _) g = f b t g -withPieces :: (Int -> Strategy) -> Strategy -withPieces f = withBoard $ \b -> f (IntMap.size (active b) + IntMap.size (inactive b)) +withNPieces :: (Int -> Strategy) -> Strategy +withNPieces 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 a branches) = s $ GameTree a branches2 +winOrPreventLoss s (GameTree node branches) = s $ GameTree node branches2 where - winning = [ (t, b) | (t, b@(GameTree _ [])) <- branches ] -{- - losing = [ t | (t, (GameTree _ branches')) <- branches, - (_, (GameTree _ [])) <- branches' ] --} + winning = [ (m1, b1) | (m1,b1@(GameTree _ branches'))<-branches, + (m2, GameTree _ []) <- branches'] branches1 = (if not (null winning) then [head winning] else if length branches BoardTree narrow (GameTree board branches) - = GameTree board [ (t, narrow g) - | (t@(_,Just(_,dest)),g)<-branches, - dest`IntMap.member`(active board)] + = 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 @@ -96,9 +92,10 @@ narrow (GameTree node branches) | null branches' = GameTree node branches | otherwise = GameTree node branches' - where branches' = [(t, narrow g) | (t@(m1,Just m2),g)<-branches] + where branches' = [(m, narrow g) | (m,g)<-branches, m/=Pass] +{- -- eliminate double-captures that lead to identical boards nubDoubleCaptures :: Strategy -> Strategy nubDoubleCaptures s g rndgen = s (narrow g) rndgen @@ -107,4 +104,4 @@ equiv ((m1,Just m2),_) ((m2', Just m1'),_) = fst m1/=fst m2 && m1==m1' && m2==m2' equiv _ _ = False - +-} diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -3,10 +3,11 @@ module Board ( -- * Types - Board - , whiteTurn - , active - , inactive + Board (..) + --, move + --, player + --, active + --, inactive , whites , blacks , boardSize @@ -19,7 +20,7 @@ , APosition (..) , fromAPos , toAPos - , Move + , Move (..) , Turn -- , AtPosition , Strategy @@ -29,12 +30,14 @@ , startBoardTree , mapTree , mapTree' - , isEndGame - , swapBoard - , swapBoardTree + , endGame + , endGameTree + --, swapBoard + --, swapBoardTree , nextCaptureMoves , nextStackingMoves , nextTurns + , nextMoves , countStacks , sixLines , atPosition @@ -59,17 +62,18 @@ -- | The board state -- | current turn, active player pieces, other player pieces -data Board = Board { whiteTurn :: !Bool, +data Board = Board { player :: !Bool, -- True=white, False=black + move :: !Int, -- 1 or 2 active :: !HalfBoard, - inactive :: !HalfBoard } - deriving (Eq,Show) + inactive :: !HalfBoard + } deriving (Eq,Show,Read) -- | A Half-board maps (unboxed) positions to pieces type HalfBoard = IntMap Piece -- | The three types of pieces -- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts. -data Type = Tzaar | Tzarra | Tott deriving (Show, Eq, Ord) +data Type = Tzaar | Tzarra | Tott deriving (Show, Read, Eq, Ord) -- | the type of a piece, and the level of the stack (starting with 1). type Piece = (Type,Int) @@ -86,7 +90,7 @@ | G1 | G2 | G3 | G4 | G5 | G6 | G7 | H1 | H2 | H3 | H4 | H5 | H6 | I1 | I2 | I3 | I4 | I5 - deriving (Show, Eq, Ord, Enum, Bounded) + deriving (Show,Read, Eq, Ord, Enum, Bounded) -- | "Unboxed" integer board positions type Position = Int @@ -98,18 +102,22 @@ toAPos :: Position -> APosition toAPos = toEnum --- | A move is one position to another, for either capturing or stacking. -type Move = (Position, Position) +-- | 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 move, followed by an optional move. -type Turn = (Move, Maybe Move) +-- | A complete turn is a pair of moves +type Turn = (Move, Move) -- | A game tree with nodes s and moves m -data GameTree s m = GameTree s [(m, GameTree s m)] deriving Show +data GameTree s m = GameTree !s [(m, GameTree s m)] deriving Show --- | A game tree of boards labeled with a boolean -type BoardTree = GameTree Board Turn +-- | 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) @@ -128,56 +136,71 @@ positions = map fromAPos [minBound .. maxBound] showTurn :: Turn -> String -showTurn (a, Nothing) = showMove a -showTurn (a, Just b ) = showMove a ++ " " ++ showMove b +showTurn (a, b) = showMove a ++ " " ++ showMove b showMove :: Move -> String -showMove (a, b) = show (toAPos a) ++ " -> " ++ show (toAPos b) - +showMove (Capture a b) = show (toAPos a) ++ "x" ++ show (toAPos b) +showMove (Stack a b) = show (toAPos a) ++ "-" ++ show (toAPos b) +showMove Pass = "pass" -- | Projections to get the white & black half-boards whites, blacks :: Board -> HalfBoard -whites (Board True you other) = you -whites (Board False you other) = other -blacks (Board True you other) = other -blacks (Board False you other) = you +whites board | player board = active board + | otherwise = inactive board +blacks board | player board = inactive board + | otherwise = active board + -- | board size (number of pieces) boardSize :: Board -> Int -boardSize (Board _ you other) = IntMap.size you + IntMap.size other +boardSize board = IntMap.size (active board) + IntMap.size (inactive board) -- | next complete turns for the active player nextTurns :: Board -> [Turn] -nextTurns board@(Board _ you _) +nextTurns board | lostOneOfThree = [] | otherwise = captureCapture ++ captureStack ++ captureNothing where - a = nextCaptureMoves board - b = map (applyMove board) a - c = map nextCaptureMoves b - d = map nextStackingMoves b - captureCapture = [ (a, Just b) | (a, x) <- zip a c, b <- x ] - captureStack = [ (a, Just b) | (a, x) <- zip a d, b <- x ] - captureNothing = zip a $ repeat Nothing - lostOneOfThree = minimum (countStacks you) == 0 + 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) +-- | next moves for the active player +nextMoves :: Board -> [Move] +nextMoves board + = case move board of + 1 -> nextCaptureMoves board + 2 -> nextStackingMoves board ++ nextCaptureMoves board ++ [Pass] + _ -> error "nextMoves: invalid board" + + + -- | next capture moves for the active player nextCaptureMoves :: Board -> [Move] -nextCaptureMoves board@(Board who you _) = IntMap.foldWithKey forPiece [] you +nextCaptureMoves board = IntMap.foldWithKey forPiece [] you where - forPiece :: Position -> Piece -> [Move] -> [Move] - forPiece !p (_, !i) moves = foldl' downLine moves (sixLines p) - where - downLine :: [Move] -> [Position] -> [Move] - downLine moves [] = moves - downLine moves (q:ps) = case atPosition board q of - Nothing -> downLine moves ps - Just (who', (_, j)) | who/=who' && i>=j -> (p,q):moves - _ -> moves + you = active board + who = player board + forPiece :: Position -> Piece -> [Move] -> [Move] + forPiece !p (_, !i) moves = foldl' downLine moves (sixLines p) + where + downLine :: [Move] -> [Position] -> [Move] + downLine moves [] = moves + downLine moves (q:ps) + = case atPosition board q of + Nothing -> downLine moves ps + Just (who', (_, j)) | who/=who' && i>=j -> (Capture p q):moves + _ -> moves {- @@ -198,8 +221,10 @@ -- | next stacking moves for the active player nextStackingMoves :: Board -> [Move] -nextStackingMoves board@(Board who you _) = foldl' forPiece [] (IntMap.keys you) +nextStackingMoves board = foldl' forPiece [] (IntMap.keys you) where + who = player board + you = active board (tzaars:tzarras:totts: _) = countStacks you forPiece :: [Move] -> Position -> [Move] forPiece moves p = foldl' downLine moves (sixLines p) @@ -213,7 +238,7 @@ Just (_, (Tzaar,_)) | tzaars==1 -> moves Just (_, (Tzarra,_)) | tzarras==1 -> moves Just (_, (Tott, _)) | totts==1 -> moves - Just (_, _) -> (p,q) : moves + Just (_, _) -> (Stack p q) : moves {- @@ -246,45 +271,90 @@ count !x !y !z ((Tott,_):ps) = count x y (1+z) ps count !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 + 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 + + + {- -countStacks :: HalfBoard -> [Int] -countStacks b = [tzaars, tzarras, totts] +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)) where - tzaars = IntMap.fold (\(!t,_) !s -> - case t of { Tzaar-> s+1; _ -> s}) 0 b - tzarras = IntMap.fold (\(!t,_) !s -> - case t of { Tzarra-> s+1; _ -> s}) 0 b - totts = IntMap.fold (\(!t,_) !s -> - case t of { Tott-> s+1; _ -> s}) 0 b - + 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 --- | Swaps board positions after the end of a turn -swapBoard :: Board -> Board -swapBoard (Board who you other) = Board (not who) other you --- | Create a board tree from a board +-- | Create a board tree from a mid-game position boardTree :: Board -> BoardTree -boardTree b - = GameTree b [(t, boardTree (swapBoard $ applyTurn b t)) | t<-nextTurns b] +boardTree b = GameTree b [(m, boardTree (applyMove b m)) | m<-nextMoves b] --- | Consider single captures only for the white's first turn +-- | Create a board tree from a start position +-- | single captures only for the white's first turn startBoardTree :: Board -> BoardTree -startBoardTree = firstTurn . boardTree - where - firstTurn (GameTree node branches) - = GameTree node [t | t@((m,Nothing),bt)<-branches] +startBoardTree b = GameTree b [(m, GameTree b' [(Pass, boardTree b'')]) + | m<-nextCaptureMoves b, + let b'=applyMove b m, let b''=applyMove b' Pass] -swapBoardTree :: BoardTree -> BoardTree -swapBoardTree = mapTree swapBoard --- | Check for a game tree leaf (i.e. end of game situation) -isEndGame :: GameTree s m -> Bool -isEndGame (GameTree _ branches) = null branches +-- | Check for a end of game position +endGame :: Board -> Bool +endGame b = move b==1 && null (nextTurns b) +-- | Check for a end of game tree +endGameTree :: GameTree s m -> Bool +endGameTree (GameTree _ []) = True +endGameTree _ = False + + -- | some auxiliary functions over game trees -- apply a function to each node mapTree :: (a->b) -> GameTree a m -> GameTree b m @@ -299,13 +369,16 @@ -- | Query the state of a board position. atPosition :: Board -> Position -> Maybe (Bool,Piece) -atPosition (Board who you other) pos +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 = player board + you = active board + other = inactive board -- | All the lines that form connected positions on the board. @@ -322,7 +395,6 @@ , [G1, G2, G3, G4, G5, G6, G7] , [H1, H2, H3, H4, H5, H6] , [I1, I2, I3, I4, I5] - , [A1, B1, C1, D1, E1] , [A2, B2, C2, D2, E2, F1] , [A3, B3, C3, D3, E3, F2, G1] @@ -364,58 +436,18 @@ --- | The next board state after a move. --- | Assumes white is next to move and move is valid. -applyMove :: Board -> Move -> Board -applyMove (Board who you other) (x,y) - = Board who you' other' - where - capture = IntMap.member y other -- capture or stacking? - (typeX, sizeX) = you!x - (_ , sizeY) | capture = other!y - | otherwise = you!y - piece | capture = (typeX, sizeX) - | otherwise = (typeX, sizeX + sizeY) - you' = IntMap.insert y piece (IntMap.delete x you) - other' | capture = IntMap.delete y other - | otherwise = other -{- -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)) - 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 (a, Just b ) = applyMove (applyMove board a) b -applyTurn board (a, Nothing) = applyMove board a - -- | An empty board emptyBoard :: Board -emptyBoard = Board True (IntMap.empty) (IntMap.empty) +emptyBoard = Board True 1 (IntMap.empty) (IntMap.empty) -- | The default (non-randomized, non-tournament) starting position. startingBoard :: Board -startingBoard = Board True (IntMap.fromList whites) (IntMap.fromList blacks) +startingBoard = Board True 1 (IntMap.fromList whites) (IntMap.fromList blacks) where f t p = (p, (t, 1)) whites = map (f Tzaar) wTzaars ++ map (f Tzarra) wTzarras ++ map (f Tott) wTotts @@ -432,7 +464,7 @@ -- | A randomized starting position randomBoard :: StdGen -> (Board, StdGen) randomBoard rnd - = (Board True (IntMap.fromList whites) (IntMap.fromList blacks), 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) @@ -441,6 +473,7 @@ blacks = zip (drop 30 positions') pieces + -- an auxilary function to shuffle a list randomly shuffle :: StdGen -> [a] -> ([a], StdGen) shuffle g xs = shuffle' g xs (length xs) @@ -471,9 +504,9 @@ instance Arbitrary Board where arbitrary = sized genBoard - shrink (Board who you other) - = [Board who you' other | you'<-shrinkHalf you] ++ - [Board who you other' | other'<-shrinkHalf other] + shrink board + = [board {active=you} | you<-shrinkHalf (active board)] ++ + [board {inactive=other} | other<-shrinkHalf (inactive board)] -- helper function to shrink half-boards @@ -494,7 +527,7 @@ who <- arbitrary let whites = zip (take n' positions') ws let blacks = zip (drop n' positions') bs - return $ Board who (IntMap.fromList whites) (IntMap.fromList blacks) + return $ Board who 1 (IntMap.fromList whites) (IntMap.fromList blacks) where n' = (min 60 n)`div`2 diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -1,5 +1,7 @@ - - +{- + GTK GUI interface for HsTZAAR board game + Pedro Vasconcelos, 2011 +-} module GUI (gui) where import Graphics.UI.Gtk hiding (eventSent,on) @@ -11,48 +13,48 @@ import qualified Data.IntMap as IntMap import Data.IntMap (IntMap, (!)) import Data.List (minimumBy, sortBy) -import Data.IORef import Control.Concurrent import Control.Monad (when) import System.Random +import StateVar (StateVar) +import qualified StateVar as StateVar import Board import AI -import AI.Eval -- | Piece colors data PieceColor = White | Black deriving (Eq,Show) -- | Record to hold the game state -data State = State - { board :: Board -- current board - , turns :: [Turn] -- valid turns +data State = State + { board :: Board -- current board + , moves :: [Move] -- available moves + , trail :: [Move] -- trail from previous turn , history :: [State] -- undo/redo history , future :: [State] - , stdGen :: StdGen -- random number generator + , stdGen :: !StdGen -- random number generator , ai :: AI -- ai player , stage :: Stage -- selection stage } data Stage - = Start0 -- first turn, single move - | Start1 Position - | Wait0 -- subsequent turns, two moves - | Wait1 Position -- 1st position - | Wait2 Move -- 1st move - | Wait3 Move Position -- 1st move, 2nd position - | Wait4 Turn -- end of turn, waiting for AI + = Start0 -- wait for 1st turn + | Start1 Position -- wait for 1st turn (2nd position) + | Wait0 -- wait for move (1st position) + | Wait1 Position -- wait for move (2nd position) + | Wait2 -- end of turn, waiting for AI | Finish -- game end deriving Eq -- | A reference to mutable state -type StateRef = IORef State +type StateRef = StateVar State -- | A state with an empty board (before game starts) emptyState :: StdGen -> State emptyState rnd = State { board = emptyBoard, - turns = [], + moves = [], + trail = [], history = [], future = [], stdGen = rnd, @@ -68,8 +70,8 @@ initState rnd ai = State { board = startingBoard , history = [] - -- first turn must be a single capture - , turns = zip (nextCaptureMoves startingBoard) (repeat Nothing) + , moves = nextMoves startingBoard + , trail = [] , future = [] , stdGen = rnd , ai = ai @@ -80,8 +82,8 @@ initRandomState :: StdGen -> AI -> State initRandomState rnd ai = State { board = b - -- first turn must be a single capture - , turns = zip (nextCaptureMoves b) (repeat Nothing) + , moves = nextMoves b + , trail = [] , history = [] , future = [] , stdGen = rnd' @@ -103,6 +105,7 @@ menu_item_redo :: MenuItem, menu_item_pass :: MenuItem, menu_item_show_heights :: CheckMenuItem, + menu_item_show_moves :: CheckMenuItem, menu_item_random_start :: CheckMenuItem, menu_item_ai_players :: [RadioMenuItem], contextid :: ContextId @@ -114,14 +117,13 @@ do initGUI gui <- loadGlade gladepath rnd <- getStdGen - stateRef <- newIORef (emptyState rnd) + stateRef <- StateVar.new (emptyState rnd) connect_events gui stateRef -- timer event for running other threads timeoutAdd (yield >> return True) 50 - -- timer event for updating the progress bar & gui widgets + -- timer event for updating the progress bar timeoutAdd (updateProgress gui stateRef >> return True) 100 - timeoutAdd (updateWidgets gui stateRef >> return True) 500 -- start event loop mainGUI @@ -131,7 +133,7 @@ -- load gui elements from XML Glade file loadGlade gladepath = do out <- xmlNew gladepath - when (out==Nothing) $ error "failed to load glade file" + when (out==Nothing) (error "failed to load glade file") let Just xml = out mw <- xmlGetWidget xml castToWindow "mainwindow" fr <- xmlGetWidget xml castToFrame "frame1" @@ -143,6 +145,7 @@ mre<- xmlGetWidget xml castToMenuItem "menu_item_redo" mpa<- xmlGetWidget xml castToMenuItem "menu_item_pass" msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights" + msm<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_moves" mrs<- xmlGetWidget xml castToCheckMenuItem "menu_item_random_start" -- fill in dynamic parts @@ -150,17 +153,17 @@ containerAdd fr bd m<- xmlGetWidget xml castToMenu "menu_ai" - r <- radioMenuItemNewWithLabel (name $ head ai_players) + r <- radioMenuItemNewWithLabel (name $ head aiPlayers) menuAttach m r 0 1 0 1 rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name t) menuAttach m w 0 1 i (i+1) return w - | (t,i)<-zip (tail ai_players) [1..]] + | (t,i)<-zip (tail aiPlayers) [1..]] cid <- statusbarGetContextId sb "status" widgetShowAll mw - return $ GUI mw bd sb pb mn mq mun mre mpa msh mrs (r:rs) cid + return $ GUI mw bd sb pb mn mq mun mre mpa msh msm mrs (r:rs) cid @@ -172,45 +175,38 @@ do mp<-getPosition (canvas gui) (eventX x) (eventY x) case mp of Nothing -> return (eventSent x) - Just p -> do selectPosition gui stateRef p + Just p -> do clickPosition gui stateRef p return (eventSent x) sequence_ [ onActivateLeaf item (set_ai player) | (player,item) <- - zip ai_players (menu_item_ai_players gui) ] + zip aiPlayers (menu_item_ai_players gui) ] onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_quit gui) mainQuit - - onActivateLeaf (menu_item_new gui) $ - do newGame gui stateRef - redrawCanvas (canvas gui) - - onActivateLeaf (menu_item_undo gui) $ - do modifyIORef stateRef prevHistory - redrawCanvas (canvas gui) - onActivateLeaf (menu_item_redo gui) $ - do modifyIORef stateRef nextHistory - redrawCanvas (canvas gui) + onActivateLeaf (menu_item_new gui) $ newGame gui stateRef + onActivateLeaf (menu_item_undo gui) $ StateVar.modify stateRef prevHistory + onActivateLeaf (menu_item_redo gui) $ StateVar.modify stateRef nextHistory onActivateLeaf (menu_item_pass gui) (movePass gui stateRef) - onActivateLeaf (menu_item_show_heights 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 + StateVar.watch stateRef $ \s -> do {updateWidgets gui s; redrawCanvas (canvas gui)} - where set_ai player = modifyIORef stateRef $ \s->s{ai=player} + where set_ai player = StateVar.modify stateRef $ \s->s{ai=player} newGame :: GUI -> StateRef -> IO () newGame gui stateRef - = do s <- readIORef stateRef + = do s <- StateVar.get stateRef ai <- getAI gui random <- checkMenuItemGetActive (menu_item_random_start gui) - writeIORef stateRef $ + StateVar.set stateRef $ if random then initRandomState (stdGen s) ai else initState (stdGen s) ai - updateWidgets gui stateRef gui `pushMsg` "Ready" @@ -219,7 +215,7 @@ getAI gui = do bs <- sequence [checkMenuItemGetActive item | item<-menu_item_ai_players gui] - return $ head [ai | (True,ai)<-zip bs ai_players] + return $ head [ai | (True,ai)<-zip bs aiPlayers] @@ -233,33 +229,24 @@ - -- update progress bar if we are waiting for AI updateProgress :: GUI -> StateRef -> IO () updateProgress gui stateRef - = do s <- readIORef stateRef + = do s <- StateVar.get stateRef case stage s of - Wait4 _ -> progressBarPulse (progressbar gui) + Wait2 -> progressBarPulse (progressbar gui) _ -> progressBarSetFraction (progressbar gui) 0 -- update widgets sensitivity -updateWidgets :: GUI -> StateRef -> IO () -updateWidgets gui stateRef - = do s<-readIORef stateRef - -- move undo/redo - case stage s of - Wait4 _ -> do widgetSetSensitive (menu_item_undo gui) False - widgetSetSensitive (menu_item_redo gui) False - _ -> do widgetSetSensitive (menu_item_undo gui) (notNull $ history s) - widgetSetSensitive (menu_item_redo gui) (notNull $ future s) - -- move pass - case stage s of - Wait2 _ -> widgetSetSensitive (menu_item_pass gui) True - _ -> widgetSetSensitive (menu_item_pass gui) False +updateWidgets :: GUI -> State -> IO () +updateWidgets gui s + = do { widgetSetSensitive (menu_item_undo gui) (stage s/=Wait2 && notNull (history s)) + ; widgetSetSensitive (menu_item_redo gui) (stage s/=Wait2 && notNull (future s)) + ; widgetSetSensitive (menu_item_pass gui) (stage s==Wait0 && move (board s)==2) + } - notNull :: [a] -> Bool notNull = not . null @@ -273,22 +260,21 @@ -- should we record this state ? -recState :: State -> Bool -recState s = case stage s of - Start0 -> True - Wait0 -> True - Wait2 m -> True - Finish -> True - _ -> False - - +recState :: State -> [State] -> [State] +recState s ss + = case stage s of + Start0 -> s:ss + Wait0 -> s:ss + Wait1 _ -> s:ss + Finish -> s:ss + _ -> ss -- move backwards/foward in history prevHistory :: State -> State prevHistory s = case history s of [] -> s - (s':ss) -> s' {history=ss, future=if recState s then s:future s else future s} + (s':ss) -> s' {history = ss, future = recState s (future s), trail=[]} @@ -296,16 +282,17 @@ nextHistory s = case future s of [] -> s - (s':ss) -> s' {history=if recState s then s:history s else history s, future=ss} + (s':ss) -> s' {history = recState s (history s), future = ss, trail=[]} -- pass the 2nd move of a turn movePass :: GUI -> StateRef -> IO () movePass gui stateRef - = do s <- readIORef stateRef + = do s <- StateVar.get stateRef + let b = board s case stage s of - Wait2 m -> dispatchTurn gui stateRef s (m,Nothing) + Wait0 | move b==2 -> dispatch gui stateRef (applyMove b Pass) _ -> return () @@ -319,21 +306,22 @@ -- redraw the canvas using double-buffering drawCanvas :: GUI -> StateRef -> IO () drawCanvas gui stateRef - = do b <- checkMenuItemGetActive (menu_item_show_heights gui) + = do b1 <- checkMenuItemGetActive (menu_item_show_heights gui) + b2 <- checkMenuItemGetActive (menu_item_show_moves gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui) - state <- readIORef stateRef + s <- StateVar.get stateRef renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp -> - do renderWith tmp (setTransform w h >> renderBoard b state) + do renderWith tmp (setTransform w h >> renderBoard b1 b2 s) setSourceSurface tmp 0 0 paint -- render the board and pieces -renderBoard :: Bool -> State -> Render () -renderBoard heights state +renderBoard :: Bool -> Bool -> State -> Render () +renderBoard showheights showmoves state = do -- paint the background boardBg >> paint -- paint the playing area light gray @@ -346,17 +334,54 @@ renderGrid -- draw the pieces & highlight selection case stage state of - Start0 -> pieces b >>= renderHeights heights - Start1 p -> highlight p >> pieces b >>= renderHeights heights - Wait0 -> pieces b >>= renderHeights heights - Wait1 p -> highlight p >> pieces b >>= renderHeights heights - Wait2 m -> pieces (applyMove b m) >>= renderHeights heights - Wait3 m p -> highlight p >> pieces (applyMove b m) >>= renderHeights heights - Wait4 t -> pieces (applyTurn b t) >>= renderHeights heights - Finish -> pieces b >>= renderHeights heights + Start0 -> pieces showheights b + Start1 p -> do highlight p + pieces showheights b + when showmoves $ mapM_ renderMove (targets p) + Wait0 -> do pieces showheights b + when showmoves $ mapM_ renderMove (trail state) + Wait1 p -> do highlight p + pieces showheights b + when showmoves $ mapM_ renderMove (targets p) + Wait2 -> do pieces showheights b + when showmoves $ mapM_ renderMove (trail state) + Finish -> do pieces showheights b + when showmoves $ mapM_ renderMove (trail state) where b = board state + targets p = [m | m@(Capture p1 p2)<-moves state, p1==p] ++ + [m | m@(Stack p1 p2)<-moves state, 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 Pass = return () +arrowFromTo :: Position -> Position -> Render () +arrowFromTo p1 p2 = do setLineWidth 10 + moveTo xstart ystart + lineTo x0 y0 + stroke + setLineWidth 1 + moveTo xend yend + lineTo x1 y1 + lineTo x2 y2 + fill + where (xstart,ystart) = screenCoordinate p1 + (xend,yend) = screenCoordinate p2 + angle = pi + atan2 (yend-ystart) (xend-xstart) + arrow_deg = pi/4 + arrow_len = 30 + x0 = xend + arrow_len * cos arrow_deg * cos angle + y0 = yend + arrow_len * cos arrow_deg * sin angle + x1 = xend + arrow_len * cos (angle-arrow_deg) + y1 = yend + arrow_len * sin (angle-arrow_deg) + x2 = xend + arrow_len * cos (angle+arrow_deg) + y2 = yend + arrow_len * sin (angle+arrow_deg) + + + -- draw the hexagonal grid and edge coordinates renderGrid :: Render () renderGrid = do gray 0 @@ -408,9 +433,9 @@ -- highlight a position -highlight :: Position -> Render () -highlight p = - do setSourceRGBA 1 0 0 0.5 +highlight :: Position -> Render () +highlight p = + do setSourceRGBA 0.5 0.5 0.5 0.5 setLineWidth 4 newPath uncurry (disc 1.5) (screenCoordinate p) @@ -418,12 +443,10 @@ -- render all pieces in the board --- returns the original board for futher use -pieces :: Board -> Render Board -pieces board +pieces :: Bool -> Board -> Render () +pieces showheights board = do setLineWidth 2 - mapM_ piece ps - return board + mapM_ (piece showheights) ps -- sort pieces by reverse position to draw from back to front where ps = sortBy cmp $ zip (repeat White) (IntMap.assocs (whites board)) ++ @@ -431,22 +454,42 @@ cmp (_,(x,_)) (_,(y,_)) = compare y x -piece :: (PieceColor,(Position,Piece))-> Render () -piece (c,(p,(t,size))) = stack size yc - where (xc,yc)= screenCoordinate p +piece :: Bool -> (PieceColor,(Position,Piece))-> Render () +piece showheight (c,(p,(t,size))) + = do y<-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 + setSourceRGB 1 0 0 + showCenteredText xc y label + where label = show size + (xc,yc)= screenCoordinate p (chipColor, lineColor, crownColor) = pieceColors c stack 0 y = case t of - Tott -> return () - Tzarra -> crownColor >> disc 0.4 xc y + 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 + crownColor >> disc 0.4 xc y >> + return y 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 +showCenteredText :: Double -> Double -> String -> Render () +showCenteredText x y txt + = do exts <- textExtents txt + let dx = textExtentsWidth exts/2 + let dy = textExtentsHeight exts/2 + moveTo (x-dx) (y+dy) + showText txt + + disc :: Double -> Double -> Double -> Render () disc r x y = arc x y (r*33) 0 (2*pi) >> fill @@ -465,29 +508,7 @@ --- label each position with the stack height --- ignore single piece stacks -renderHeights :: Bool -> Board -> Render () -renderHeights flag board - = when flag $ - do selectFontFace "monospace" FontSlantNormal FontWeightBold - setFontSize 50 - setSourceRGB 1 0 0 - mapM_ renderHeight (IntMap.assocs (whites board)) - mapM_ renderHeight (IntMap.assocs (blacks board)) - where - renderHeight (p, (_, h)) - | h>1 = do moveTo (x-15) (y+12-8*dy) - showText txt - | otherwise = return () - where (x,y) = screenCoordinate p - dy = fromIntegral h - 1 - txt = show h - - - - -- convert a canvas coordinate to a board position getPosition :: DrawingArea -> Double -> Double -> IO (Maybe Position) getPosition canvas x y @@ -503,95 +524,65 @@ -- dispatch a button click on a board position -selectPosition :: GUI -> StateRef -> Position -> IO () -selectPosition gui stateRef p - = do s <- readIORef stateRef - -- valid turns from this position +-- check move is valid from this position +clickPosition :: GUI -> StateRef -> Position -> IO () +clickPosition gui stateRef p + = do s <- StateVar.get stateRef case stage s of - Start0 | notNull [p0 | ((p0, _), _)<-turns s, p0==p] -> + Start0 | notNull [p0 | (Capture p0 _)<-moves s, p0==p] -> let s'= addHistory s - in do writeIORef stateRef $ s' {stage=Start1 p} - redrawCanvas cv - Start1 p0 | p0==p -> do modifyIORef stateRef prevHistory - redrawCanvas cv - Start1 p0 | notNull [m | (m, _)<- turns s, m==(p0,p)] -> - dispatchTurn gui stateRef s ((p0,p),Nothing) - --- - Wait0 | notNull [p0 | ((p0, _), _)<-turns s, p0==p] -> + in StateVar.set stateRef $ s' {stage=Start1 p} + Start1 p0 | p0==p -> StateVar.modify stateRef prevHistory + + Start1 p0 | Capture p0 p `elem` moves s -> + do StateVar.modify stateRef $ + \s -> s{trail=Capture p0 p:trail s} + dispatch gui stateRef (applyTurn (board s) (Capture p0 p,Pass)) + Wait0 | notNull [p0 | Capture p0 _<-moves s, p0==p] || + notNull [p0 | Stack p0 _<-moves s, p0==p] -> let s'= addHistory s - in do writeIORef stateRef $ s' {stage=Wait1 p} - redrawCanvas cv - Wait1 p0 | p0==p -> do modifyIORef stateRef prevHistory - redrawCanvas cv - Wait1 p0 | notNull [m | (m, _)<- turns s, m==(p0,p)] -> - do writeIORef stateRef $ s {stage=Wait2 (p0,p)} - redrawCanvas cv - Wait2 m | notNull [p0 | (m', Just (p0, _))<-turns s, m==m', p0==p] -> - let s'= addHistory s - in do writeIORef stateRef $ s' {stage=Wait3 m p} - redrawCanvas cv - Wait3 m p0 | p0==p -> do modifyIORef stateRef prevHistory - redrawCanvas cv - Wait3 m p0 | t`elem`turns s -> dispatchTurn gui stateRef s t - where t = (m, Just (p0, p)) + in StateVar.set stateRef $ s' {stage=Wait1 p, trail=[]} + Wait1 p0 | p0==p -> StateVar.modify stateRef prevHistory + Wait1 p0 | Capture p0 p`elem`moves s -> + do StateVar.modify stateRef $ + \s -> s {trail = Capture p0 p : trail s} + dispatch gui stateRef (applyMove (board s) (Capture p0 p)) + Wait1 p0 | Stack p0 p`elem`moves s -> + do StateVar.modify stateRef $ + \s -> s {trail = Stack p0 p : trail s} + dispatch gui stateRef (applyMove (board s) (Stack p0 p)) _ -> return () - where cv = canvas gui - -dispatchTurn :: GUI -> StateRef -> State -> Turn -> IO () -dispatchTurn gui stateRef s t - | isEndGame bt -- human player wins - = let s' = s { stage = Finish, - turns = [], - board = b } - in do gui `pushMsg` "White wins" - writeIORef stateRef s' - redrawCanvas (canvas gui) - | otherwise - = do { writeIORef stateRef $ s {stage = Wait4 t, turns = []} - ; redrawCanvas (canvas gui) - ; gui `pushMsg` "Thinking..." - ; forkIO child - ; return () - } - where - b = swapBoard (applyTurn (board s) t) -- apply turn and swap active player - bt = boardTree b - (t', rnd') = strategy (ai s) bt (stdGen s) - b' = swapBoard (applyTurn b t') - turns' = nextTurns b' - child = if null turns' then -- computer wins - let s'= s { stage = Finish, - board = b', - turns = [], - stdGen = rnd' } - in do writeIORef stateRef s' - redrawCanvas (canvas gui) - gui `pushMsg` "Black wins" - else - let s' = s { stage = Wait0, - board = b', - turns = turns', - stdGen = rnd' - } - in do writeIORef stateRef s' - redrawCanvas (canvas gui) - gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t') - putStrLn ("White value: " ++ show (static_eval $ board s') ++ - "\tBlack value: " ++ show (static_eval $ swapBoard $ board s')) - - -{- - GameTree _ branches = bt s - bt'@(GameTree _ branches') = swapBoardTree $ fromJust $ lookup t branches - (t', g) = strategy (ai s) bt' (stdGen s) - bt''@(GameTree _ branches'') - = swapBoardTree $ case lookup t' branches' of - Nothing -> error ("Invalid AI move: " ++ show t') - Just a -> a --} - +dispatch :: GUI -> StateRef -> Board -> IO () +dispatch gui stateRef b + | endGame b = do { gui `pushMsg` + (if player b then "Black wins" else "White wins") + ; StateVar.modify stateRef $ + \s -> s {stage=Finish, board=b, moves=[]} + } + | player b -- White to move + = StateVar.modify stateRef $ + \s -> s {stage=Wait0, board=b, moves=nextMoves b} + | otherwise -- Black to move + = do { gui `pushMsg` "Thinking..." + ; StateVar.modify stateRef $ \s -> s{stage=Wait2, moves=[], board=b} + ; forkIO async + ; return () + } + where + -- asynchronous action for the AI player + async = do { s <- StateVar.get stateRef + ; let b = board s + ; let bt = boardTree b + ; let (t@(m1,m2), rnd') = strategy (ai s) bt (stdGen s) + ; gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t) + ; StateVar.modify stateRef $ \s -> s { stdGen = rnd' + , trail = [m1,m2] + } + ; dispatch gui stateRef (applyTurn b t) + } + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -37,7 +37,7 @@ header, footer :: String header = "usage: hstzaar [OPTION..] [AI AI]" -footer = " where AI is one of: " ++ unwords [name ai | ai<-ai_players] +footer = " where AI is one of: " ++ unwords [name ai | ai<-aiPlayers] -- default number of matches for AI tournaments @@ -72,7 +72,7 @@ string_to_AI :: String -> IO AI string_to_AI n - = case [p | p<-ai_players, name p==n] of + = case [p | p<-aiPlayers, name p==n] of [] -> ioError $ userError ("invalid AI: " ++ n) (p:_) -> return p diff --git a/src/StateVar.hs b/src/StateVar.hs new file mode 100644 --- /dev/null +++ b/src/StateVar.hs @@ -0,0 +1,49 @@ +-- State variables for IO refs +-- Encapsulates mutable references with callback functions +-- pbv, 2011 +module StateVar + ( StateVar, + new, get, set, modify, watch + ) where + +import Data.IORef + +-- a state variable is pair of mutable ref and mutable callback +data StateVar a = StateVar !(IORef a) !(IORef (a -> IO ())) + +-- make a new state var with given value and null callback +new :: a -> IO (StateVar a) +new v = do ref <- newIORef v + callback <- newIORef (\_ -> return ()) + return (StateVar ref callback) + +-- assign to a state var +set :: StateVar a -> a -> IO () +set (StateVar ref callback) v + = do writeIORef ref v + cb <- readIORef callback + cb v + +-- fetch the value of a state var +get :: StateVar a -> IO a +get (StateVar ref _) = readIORef ref + +-- update a state var using a pure function +modify :: StateVar a -> (a -> a) -> IO () +modify (StateVar 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 :: StateVar a -> (a -> IO ()) -> IO () +watch (StateVar ref callback) cb + = do writeIORef callback cb + v <- readIORef ref + cb v + + + + diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -1,6 +1,6 @@ {- Quickcheck properties for board & AI code - Pedro Vasconcelos, 2010 + Pedro Vasconcelos, 2010, 2011 -} module Tests (run_tests) where import Board @@ -42,67 +42,60 @@ -- some properties of the AI code --------------------------------------------------------------------------- -{- --- static evaluation respects the zero-sum property -prop_zero_sum :: Board -> Property -prop_zero_sum b - = admissible b ==> eval b - eval (swapBoard b) == 0 --} -- upper and lower bounds for the evaluation function prop_value_bounds :: Board -> Property -prop_value_bounds b - = not (active_lost b) && not (inactive_lost b) ==> abs value < infinity - where value = static_eval b +prop_value_bounds board + = not (active_lost board) && not (inactive_lost board) ==> abs value < infinity + where value = eval board -- end game positions give plus/minus infinityinity scores prop_inactive_lost :: Board -> Property prop_inactive_lost b - = not (active_lost b) && inactive_lost b ==> - static_eval b == infinity + = not (active_lost b) && inactive_lost b ==> eval b == infinity prop_active_lost :: Board -> Property prop_active_lost b - = not (inactive_lost b) && active_lost b ==> - static_eval b == (-infinity) - + = not (inactive_lost b) && active_lost b ==> eval b == (-infinity) --- alpha-beta pruning computes the minimax value --- parameters: number of pieces, pruning depth and breadth -prop_alpha_beta :: Int -> Int -> Int -> Property -prop_alpha_beta npieces depth breadth +-- 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 -> - not (active_lost b) ==> - let bt = mkTree depth breadth b + admissible b ==> + let bt = mkTree depth b in minimax_ab (-infinity) infinity bt == minimax bt --- extended alpha-beta minimax computes the first move of the principal variation --- parameters: number of pieces, pruning depth and breadth -prop_alpha_beta_move :: Int -> Int -> Int -> Property -prop_alpha_beta_move npieces depth breadth - = forAllShrink (resize npieces arbitrary) shrink $ \b -> - not (active_lost b) ==> - let bt = mkTree depth breadth b - (m,v)= minimaxMove_ab (-infinity) infinity bt - bt' = treeMove m bt - in minimax bt' == -v +-- 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 + | depth`mod`4 == 0 + = forAllShrink (resize npieces arbitrary) shrink $ \b -> + admissible b ==> + let bt = mkTree depth b + (v,ms)= minimaxPV 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 -mkTree :: Int -> Int -> Board -> GameTree Int Turn -mkTree depth breadth board = pruneDepth depth $ - pruneBreadth breadth $ - lowFirst $ - mapTree static_eval $ - boardTree board +mkTree :: Int -> Board -> GameTree Int Move +mkTree depth board = pruneDepth depth $ mapTree eval $ boardTree board -treeMove :: Eq m => m -> GameTree s m -> GameTree s m -treeMove m (GameTree _ branches) = head [t | (m',t)<-branches, m'==m] +treeMove :: Eq m => GameTree s m -> m -> GameTree s m +treeMove (GameTree _ branches) m = head [t | (m',t)<-branches, m'==m] + + + -- correctness of the zone of control computation -- the zone of control is the set of pieces -- that can be captured in a turn (one or two moves) @@ -111,26 +104,26 @@ where moves1 = nextCaptureMoves b moves2 = concat [nextCaptureMoves (applyMove b m) | m<-moves1] - pos = IntSet.fromList (map snd moves1 ++ map snd moves2) + pos = IntSet.fromList [dest | Capture _ dest<-(moves1++moves2)] pos'= IntMap.keysSet (zoneOfControl b) -- helper functions to filter boards, etc. -- "admissible" boards: no winner yet admissible :: Board -> Bool -admissible b - = not (active_lost b) && not (inactive_lost b) +admissible b = not (active_lost b) && not (inactive_lost b) active_lost, inactive_lost :: Board -> Bool -active_lost b = null (nextCaptureMoves b) || pieceTypes (active b)/= 3 -inactive_lost = active_lost . swapBoard - +active_lost b + = (move b==1 && null (nextCaptureMoves b)) || + any (==0) (countStacks $ active b) --- number of piece types in a half-board -pieceTypes :: HalfBoard -> Int -pieceTypes b = length $ nub $ map fst $ IntMap.elems b +inactive_lost b = any (==0) (countStacks $ inactive b) +-- number of piece types in a half-board +--pieceTypes :: HalfBoard -> Int +--pieceTypes b = length $ nub $ map fst $ IntMap.elems b -- run all tests @@ -141,20 +134,20 @@ 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_zero_sum", quickCheck prop_zero_sum) , ("prop_value_bounds", quickCheck prop_value_bounds) , ("prop_inactive_lost", quickCheck prop_inactive_lost) , ("prop_active_lost", quickCheck prop_active_lost) , ("prop_zoc_correct", quickCheck prop_zoc_correct) --, ("prop_zoc_correct2", quickCheck prop_zoc_correct2) - , ("prop_alpha_beta 10 4 5", - quickCheck (prop_alpha_beta 10 4 5)) - , ("prop_alpha_beta 15 6 5", - quickCheck (prop_alpha_beta 15 6 5)) - , ("prop_alpha_beta_move 10 4 5", - quickCheck (prop_alpha_beta_move 10 4 5)) - , ("prop_alpha_beta_move 15 6 5", - quickCheck (prop_alpha_beta_move 15 6 5)) + , ("prop_alpha_beta 10 4", + quickCheck (prop_alpha_beta 10 4)) + , ("prop_alpha_beta 15 6", + quickCheck (prop_alpha_beta 15 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)) ] diff --git a/src/Tournament.hs b/src/Tournament.hs --- a/src/Tournament.hs +++ b/src/Tournament.hs @@ -8,20 +8,19 @@ import Control.Monad -- compare two strategies on a starting board --- plays 2 games with (either strategy first) and sums the results +-- 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 board branches) rnd p1 p2 - | null branches = return (-1) -- p1 can't play, p2 wins +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 $ swapBoard (applyTurn board t) - -- bt' = head [bt' | (t',bt')<-branches, t'==t] + bt' = boardTree (applyTurn b t)