hstzaar 0.5 → 0.6
raw patch · 16 files changed
+632/−697 lines, 16 files
Files
- LICENSE +1/−1
- README +0/−89
- RELEASE-NOTES +6/−0
- data/hstzaar.glade +8/−2
- hstzaar.cabal +3/−4
- src/AI.hs +23/−3
- src/AI/Eval.hs +17/−58
- src/AI/Lame.hs +20/−22
- src/AI/Minimax.hs +69/−95
- src/AI/Utils.hs +22/−25
- src/Board.hs +157/−124
- src/GUI.hs +201/−210
- src/Main.hs +2/−2
- src/StateVar.hs +49/−0
- src/Tests.hs +50/−57
- src/Tournament.hs +4/−5
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) Pedro Vasconcelo 2010+Copyright (c) Pedro Vasconcelos 2010 All rights reserved.
− README
@@ -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-
RELEASE-NOTES view
@@ -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
data/hstzaar.glade view
@@ -1,4 +1,4 @@-<?xml version="1.0"?>+<?xml version="1.0" encoding="UTF-8"?> <glade-interface> <!-- interface-requires gtk+ 2.6 --> <!-- interface-naming-policy toplevel-contextual -->@@ -9,7 +9,6 @@ <child> <widget class="GtkVBox" id="vbox1"> <property name="visible">True</property>- <property name="orientation">vertical</property> <child> <widget class="GtkMenuBar" id="menubar1"> <property name="visible">True</property>@@ -129,6 +128,13 @@ <widget class="GtkCheckMenuItem" id="menu_item_show_heights"> <property name="visible">True</property> <property name="label" translatable="yes">Show heights</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkCheckMenuItem" id="menu_item_show_moves">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Show available moves</property> <property name="use_underline">True</property> </widget> </child>
hstzaar.cabal view
@@ -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-
src/AI.hs view
@@ -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+ )+ }
src/AI/Eval.hs view
@@ -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--}
src/AI/Lame.hs view
@@ -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
src/AI/Minimax.hs view
@@ -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
src/AI/Utils.hs view
@@ -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<cutoff @@ -84,9 +79,10 @@ g'@(GameTree _ branches') = narrow g narrow :: BoardTree -> 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-+-}
src/Board.hs view
@@ -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
src/GUI.hs view
@@ -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)+ }+
src/Main.hs view
@@ -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
+ src/StateVar.hs view
@@ -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++ ++
src/Tests.hs view
@@ -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)) ]
src/Tournament.hs view
@@ -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)