hstzaar 0.4 → 0.5
raw patch · 11 files changed
+723/−563 lines, 11 files
Files
- RELEASE-NOTES +4/−0
- hstzaar.cabal +2/−1
- src/AI.hs +2/−4
- src/AI/Eval.hs +102/−74
- src/AI/Lame.hs +4/−4
- src/AI/Minimax.hs +43/−53
- src/AI/Utils.hs +48/−72
- src/Board.hs +276/−78
- src/GUI.hs +155/−112
- src/Tests.hs +63/−137
- src/Tournament.hs +24/−28
RELEASE-NOTES view
@@ -1,3 +1,7 @@+hstzaar 0.5 29/03/2011+- corrected error in minimax algorithm that made it worse than the greedy strategy+- modified static evaluation function+- improved data structures for board representation to reduce memory footprint hstzaar 0.4 22/10/2010 - zoneOfControl computation now properly accounts for interleaved captures
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.4+version: 0.5 category: Game @@ -42,3 +42,4 @@ QuickCheck >= 2.1 ghc-prof-options: -prof -auto-all+
src/AI.hs view
@@ -6,10 +6,8 @@ import AI.Minimax --- all AI players; default AI is the first one (greedy)+-- all AI players; default AI is the first one ai_players :: [AI]-ai_players = [greedy, lame] ++ - [plyN n | n<-[1,2,4,6]] ++ - [dynamic n | n<-[2,4,6]]+ai_players = [plyN n 5 | n<-[2,3,4,5,6]] ++ [greedy,lame]
src/AI/Eval.hs view
@@ -1,92 +1,90 @@ {-# LANGUAGE BangPatterns #-}--- Static evaluation functions for board positions-module AI.Eval( eval- , value+-- Static evaluation functions of board positions+module AI.Eval( static_eval , zoneOfControl- , inf ) where import Board-import qualified Data.Map as Map----- Static evaluation function for a board position--- boolean is True if white player's turn, False for black player's turn-eval :: (Bool,Board) -> Int-eval (True, b) = value b-eval (False,b) = value (swapBoard b)--+import qualified Data.IntMap as IntMap+import Debug.Trace --- value of a board position for the white player--- assuming the white player is next to move (active player)-value :: Board -> Int-value b@(white,black)- | minimum wtypes==0 || null wcaptures = -inf- | minimum btypes==0 || null bcaptures = inf- | otherwise = material + 8*positional + threats- where - -- piece counts for each player - wtypes = countPieces white- btypes = countPieces black+-- | 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]) $ -}+ 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- wcaptures = nextCaptureMoves b- bcaptures = nextCaptureMoves (swapBoard b) -- -- the zones of control for each player- wzoc = zoneOfControl (>=) b- bzoc = zoneOfControl (>) (swapBoard b)-- -- piece types in each zone of control- wzoc_types = countPieces wzoc- bzoc_types = countPieces bzoc+ captures = nextCaptureMoves b+ captures'= nextCaptureMoves (swapBoard b) - -- material score- material = sumHeights white - sumHeights black- - -- positional score- -- positional = sumHeights wzoc - sumHeights bzoc- positional = Map.size wzoc - Map.size bzoc+ -- stack heights by piece kinds+ heights = sumHeights (active b) - -- immediate threats- threats | bt<=wt = penalty bt- | otherwise = - penalty wt+ -- material score + material = sum [(mw*h)`div`(c+1) | (c,h)<-zip counts heights] - -- immediately threatened pieces - wt = minimum [x-min 2 y | (x,y)<-zip wtypes bzoc_types]- bt = minimum [x-min 2 y | (x,y)<-zip btypes wzoc_types] + zoc = zoneOfControl b -- zone of control for the active player+ zoc_heights = sumHeights zoc -- piece types in the zone of control - penalty n | n<=2 = inf`div`2^(n+1)- | otherwise = 0+ -- positional score + positional = sum [(pw*h)`div`(c+1) | (c,h)<-zip counts' zoc_heights]+ + -- immediate threats to opponent pieces+ zoc_counts = countStacks zoc+ threats = sum [tw | (x,y)<-zip counts' zoc_counts, x<=min 2 y]+ + -- scoreing weights coeficients+ mw = 10 -- material + pw = 50 -- positional+ tw = 1000 -- threats + --- the maximum evaluation score-inf :: Int-inf = 2^10-- --- sum the heights of pieces (material value of a player)--- specification:--- sumHeights b = sum [h | (_,h)<-Map.elems b]-sumHeights :: HalfBoard -> Int-sumHeights b = sum 0 [h | (_,h)<-Map.elems b]- where sum :: Int -> [Int] -> Int- sum !s [] = s- sum !s (!x:xs) = sum (s+x) xs+-- sum of heights of stacks for each kind+sumHeights :: HalfBoard -> [Int]+sumHeights b = sum 0 0 0 (IntMap.elems b)+ where sum :: Int -> Int -> Int -> [Piece] -> [Int]+ sum !x !y !z ((Tzaar,h):ps) = sum (x+h) y z ps+ sum !x !y !z ((Tzarra,h):ps) = sum x (y+h) z ps+ sum !x !y !z ((Tott,h):ps) = sum x y (z+h) ps+ sum !x !y !z [] = [x,y,z] +-- 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 white player--- i.e. black pieces that can be captured in one or two moves-zoneOfControl :: (Int->Int->Bool) -> Board -> HalfBoard-zoneOfControl cmp board@(white,black) - = Map.filterWithKey forPiece1 black+-- Estimate the zone of control of the active player+-- i.e., the set of opponent pieces reachable in a turn (two capture moves)+zoneOfControl :: Board -> HalfBoard+zoneOfControl board+ = IntMap.filterWithKey forPiece1 other where+ you = active board+ other = inactive board+ who = whiteTurn board -- white pieces that can make at least one capture- captures = Map.filterWithKey forPiece2 white+ captures = IntMap.filterWithKey forPiece2 you forPiece1, forPiece2 :: Position -> Piece -> Bool forPiece1 p (_, i) = or $ map (downLine0 i) $ sixLines p@@ -98,24 +96,54 @@ downLine0 i (p:ps) = case atPosition board p of Nothing -> downLine0 i ps- Just (True, (_, h)) -> - h`cmp`i || (p`Map.member`captures && downLine1 i ps)- Just (False, (_, j)) -> + Just (who', (_, h)) | who'==who -> + h>=i || (p`IntMap.member`captures && downLine1 i ps)+ Just (_, (_, j)) -> or $ map (downLine1 (max i j)) $ sixLines p downLine1 i [] = False downLine1 i (p:ps) = case atPosition board p of Nothing -> downLine1 i ps- Just (True, (_, h)) -> h`cmp`i+ Just (who', (_, h)) | who'==who -> h>=i _ -> False downLine2 h [] = False downLine2 h (p:ps) = case atPosition board p of Nothing -> downLine2 h ps- Just (False, (_, i)) -> h`cmp`i+ Just (who', (_, i)) | who'/=who -> h>=i _ -> False- ++{-+--- 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
@@ -10,13 +10,13 @@ lame = AI { name = "lame" , description = "Randomly selects the next valid turn."- , strategy = (ifPieces (==60)- lameStrategy0- (winOrPreventLoss lameStrategy)+ , strategy = (withPieces $ \n -> if n==60 then lameStrategy0+ else winOrPreventLoss lameStrategy ) } --- | The lame strategy picks a valid turn at random. If a two-move turn is available, it picks one. (wow, pretty smart!)+-- | 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') where
src/AI/Minimax.hs view
@@ -1,58 +1,60 @@ module AI.Minimax( greedy , plyN- , dynamic , minimax , minimax_ab , minimaxMove , minimaxMove_ab- , prunedepth- , prunebreadth_asc ) where -import Data.List (sort, sortBy, maximumBy, minimumBy, nub, nubBy)+import Data.List (sort, sortBy, maximumBy, minimumBy) import AI.Utils import AI.Eval import Board import Debug.Trace ---- A greedy strategy--- chooses the move with highest static evaluation score+-- greedy AI player greedy :: AI greedy = AI { name = "greedy" , description = "Maximize the static evaluation function"- , strategy = (ifPieces (==60)- greedyStrategy- (winOrPreventLoss (singleCaptures greedyStrategy))+ , 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 - = trace ("[greedy score: " ++ show bestscore ++ "]") (bestmove, rndgen)+ | null branches = error "greedyStrategy: empty branches"+ | otherwise = (bestmove, rndgen) where choices = [(m, score t) | (m,t)<-branches]- (bestmove,bestscore) = maximumBy cmp choices+ (bestmove,bestscore) = minimumBy cmp choices cmp (_,x) (_,y) = compare x y - score (GameTree _ []) = inf -- opponent loses- score (GameTree b _) = -eval b -- valued by the opponent+ score (GameTree b _) = static_eval b -- valued the opponent --- straight minimaxing strategies with fixed depth-plyN :: Int -> AI-plyN n = AI { name = "ply" ++ show n- , description = "Minimax with depth " ++ show n- , strategy = (ifPieces (==60)- greedyStrategy- (winOrPreventLoss- (singleCaptures - (minimaxStrategy n 5))))- }+-- 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+ )+ } +{- -- dynamic strategy -- use greedy algorithm for opening then switching to maximaxing dynamic :: Int -> AI@@ -70,21 +72,23 @@ ) ) }-+-} --- Minimaxing strategy to ply depth `n' and breadth `m'--- FIXME: for some reason alpha-beta prunning gives --- worst results than plain minimaxing against the greedy strategy +-- 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 g rndgen - = trace ("[minimax score: "++ show bestscore ++"]") (bestmove, rndgen)- where (bestmove,bestscore) = minimaxMove g' -- minimaxMove_ab (-inf) inf g'- g' = prunebreadth_asc m $ -- ^ cut to breadth `m'- prunedepth n $ -- ^ prune to depth `n'- mapTree eval g -- ^ apply evaluation function+minimaxStrategy n m (GameTree _ []) rndgen + = error "minimaxStrategy: empty tree"+minimaxStrategy n m bt rndgen + = (bestmove, rndgen)+ where (bestmove,bestscore) = minimaxMove_ab (-infinity) infinity 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 + -- Naive minimax algorithm (not used) -- nodes should contain the static evaluation scores minimax :: (Num a, Ord a) => GameTree a m -> a @@ -109,6 +113,8 @@ where a' = - minimax_ab (-b) (-a) t ++ -- 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"@@ -120,19 +126,3 @@ where a' = - minimax_ab (-b) (-a) t -----{---- | eliminate double-captures that lead to the same board-nubCaptures :: BoardTree -> BoardTree-nubCaptures (GameTree node branches) - = GameTree node $ nubBy equiv [(t, nubCaptures g) | (t,g)<-branches]- where- equiv :: (Turn,BoardTree) -> (Turn,BoardTree) -> Bool- equiv ((m1,Just m2),_) ((m2', Just m1'),_)- = fst m1/=fst m2 && m1==m1' && m2==m2'- equiv _ _ = False- --}
src/AI/Utils.hs view
@@ -1,92 +1,55 @@ -- | Utilities for AI players. module AI.Utils ( winOrPreventLoss- , mapTree- , prunedepth- , prunebreadth- , prunebreadth_asc- -- , highfirst- -- , lowfirst- , ifPieces- , ifBranch- , singleCaptures- , dontPass+ , pruneDepth, pruneBreadth+ , highFirst, lowFirst+ , withPieces, withBoard+ , dontPass, singleCaptures, nubDoubleCaptures ) where import Board-import Data.List (sortBy, minimumBy)-import qualified Data.Map as Map+import Data.List (nubBy, sortBy, minimumBy)+import qualified Data.IntMap as IntMap import System.Random --- | some auxiliary functions over game trees--- apply a function to each node-mapTree :: (a->b) -> GameTree a m -> GameTree b m-mapTree f (GameTree x branches) - = GameTree (f x) [(m,mapTree f t) | (m,t)<-branches] --- apply a function to each edge-mapTree' :: (a->b) -> GameTree s a -> GameTree s b-mapTree' f (GameTree x branches) - = GameTree x [(f m,mapTree' f t) | (m,t)<-branches]------- heuristic to order subtrees with highest/lowest values first-highfirst, lowfirst :: GameTree Int m -> GameTree Int m-highfirst (GameTree x branches) - = GameTree x $ sortBy cmp [(m, lowfirst t) | (m,t)<-branches]- where cmp (_,x) (_,y) = compare (value y) (value x)+-- order subtrees with ascending or descending order+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) value (GameTree n _) = n -lowfirst (GameTree x branches) - = GameTree x $ sortBy cmp [(m,highfirst t) | (m,t)<-branches]- where cmp (_,x) (_, y) = compare (value x) (value y)+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) 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 :: 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] -- prune to a fixed breadth-prunebreadth :: Int -> GameTree a m -> GameTree a m-prunebreadth k (GameTree node branches) - = GameTree node [(m, prunebreadth k t) | (m,t)<-take k branches]---- prune to a fixed breadth, ordering nodes by ascending static evalution-prunebreadth_asc :: Ord s => Int -> GameTree s m -> GameTree s m-prunebreadth_asc k (GameTree node branches) - = GameTree node branches'- where - branches' = take k $ - sortBy cmp [(m,prunebreadth_asc k t) | (m,t)<-branches]- cmp (_,x) (_, y) = compare (value x) (value y)- value (GameTree n _) = n+pruneBreadth :: Int -> GameTree a m -> GameTree a m+pruneBreadth k (GameTree node branches) + = GameTree node [(m,pruneBreadth k t) | (m,t)<-take k branches] ------ | use different strategies dependening on the number of pieces left-ifPieces :: (Int->Bool) -> Strategy -> Strategy -> Strategy-ifPieces p s1 s2 g@(GameTree (_,(you,other)) branches) rndgen- | p n = s1 g rndgen -- use the 1st strategy- | otherwise = s2 g rndgen -- use the 2nd strategy- where- n = Map.size you + Map.size other+-- conditional strategies+withBoard :: (Board -> Strategy) -> Strategy+withBoard f t@(GameTree b _) g = f b t g --- | use different strategies dependening on the branching factor-ifBranch :: (Int->Bool) -> Strategy -> Strategy -> Strategy-ifBranch p s1 s2 g@(GameTree (_,(you,other)) branches) rndgen- | p (length branches) = s1 g rndgen -- 1st strategy- | otherwise = s2 g rndgen -- 2nd strategy+withPieces :: (Int -> Strategy) -> Strategy+withPieces f = withBoard $ \b -> f (IntMap.size (active b) + IntMap.size (inactive b)) @@ -112,7 +75,7 @@ --- | narrow the search space: don't consider double-capture or pass moves+-- narrow the search space: don't consider double-capture or pass moves singleCaptures :: Strategy -> Strategy singleCaptures s g@(GameTree _ branches) rndgen | null branches' = s g rndgen@@ -120,15 +83,28 @@ where g'@(GameTree _ branches') = narrow g narrow :: BoardTree -> BoardTree- narrow (GameTree node@(_, (you,_)) branches)- = GameTree node [ (t, narrow g) + narrow (GameTree board branches)+ = GameTree board [ (t, narrow g) | (t@(_,Just(_,dest)),g)<-branches, - dest`Map.member`you]+ dest`IntMap.member`(active board)] --- don't consider pass moves +-- don't consider passing moves dontPass :: Strategy -> Strategy dontPass s g rndgen = s (narrow g) rndgen where narrow :: BoardTree -> BoardTree- narrow (GameTree node branches)- = GameTree node [ (t, narrow g) | (t@(m1,Just m2),g)<-branches ]+ narrow (GameTree node branches) + | null branches' = GameTree node branches+ | otherwise = GameTree node branches'+ where branches' = [(t, narrow g) | (t@(m1,Just m2),g)<-branches]+++-- eliminate double-captures that lead to identical boards+nubDoubleCaptures :: Strategy -> Strategy+nubDoubleCaptures s g rndgen = s (narrow g) rndgen+ where narrow (GameTree node branches) + = GameTree node $ nubBy equiv [(t, narrow g) | (t,g)<-branches]+ equiv ((m1,Just m2),_) ((m2', Just m1'),_)+ = fst m1/=fst m2 && m1==m1' && m2==m2'+ equiv _ _ = False+
src/Board.hs view
@@ -3,13 +3,22 @@ module Board ( -- * Types- Board+ Board + , whiteTurn+ , active+ , inactive+ , whites+ , blacks+ , boardSize , HalfBoard , BoardTree , GameTree(..) , Type (..) , Piece- , Position (..)+ , Position+ , APosition (..)+ , fromAPos+ , toAPos , Move , Turn -- , AtPosition@@ -17,14 +26,19 @@ , AI (..) -- * Utilities , boardTree+ , startBoardTree+ , mapTree+ , mapTree'+ , isEndGame , swapBoard , swapBoardTree , nextCaptureMoves , nextStackingMoves , nextTurns- , countPieces+ , countStacks , sixLines , atPosition+ , emptyBoard , startingBoard , randomBoard , showTurn@@ -32,31 +46,37 @@ , applyMove , applyTurn , positions- , shuffle+ -- , shuffle+ , infinity ) where import Data.List-import Data.Map (Map, (!))-import qualified Data.Map as Map+import Data.IntMap (IntMap, (!))+import qualified Data.IntMap as IntMap import System.Random import Control.Monad (mplus)+import Test.QuickCheck --- | The board state is a pair of two "half-boards" (one per player)-type Board = (HalfBoard, HalfBoard)+-- | The board state+-- | current turn, active player pieces, other player pieces+data Board = Board { whiteTurn :: !Bool, + active :: !HalfBoard, + inactive :: !HalfBoard }+ deriving (Eq,Show) --- | A Half-board maps locations to pieces -type HalfBoard = Map Position Piece+-- | 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) -- | the type of a piece, and the level of the stack (starting with 1).-type Piece = (Type, Int)+type Piece = (Type,Int) --- | Board position. Letters left to right, numbers bottom to top.--- Column E has the hole in the middle.-data Position+-- | Algebraic board positions. Letters left to right, numbers bottom to top.+-- | Column E has the hole in the middle.+data APosition = A1 | A2 | A3 | A4 | A5 | B1 | B2 | B3 | B4 | B5 | B6 | C1 | C2 | C3 | C4 | C5 | C6 | C7@@ -68,6 +88,16 @@ | I1 | I2 | I3 | I4 | I5 deriving (Show, Eq, Ord, Enum, Bounded) +-- | "Unboxed" integer board positions+type Position = Int ++-- converto to/from algebraic positions+fromAPos :: APosition -> Position+fromAPos = fromEnum ++toAPos :: Position -> APosition+toAPos = toEnum + -- | A move is one position to another, for either capturing or stacking. type Move = (Position, Position) @@ -79,8 +109,7 @@ data GameTree s m = GameTree s [(m, GameTree s m)] deriving Show -- | A game tree of boards labeled with a boolean --- | True if it's white player's turn, False if black player's turn-type BoardTree = GameTree (Bool,Board) Turn+type BoardTree = GameTree Board Turn -- | An AI strategy calculates the next turn from a board tree. type Strategy = BoardTree -> StdGen -> (Turn, StdGen)@@ -96,19 +125,33 @@ -- | List of all positions (for enumeration purposes) positions :: [Position]-positions = [minBound .. maxBound]+positions = map fromAPos [minBound .. maxBound] showTurn :: Turn -> String showTurn (a, Nothing) = showMove a showTurn (a, Just b ) = showMove a ++ " " ++ showMove b showMove :: Move -> String-showMove (a, b) = show a ++ " -> " ++ show b+showMove (a, b) = show (toAPos a) ++ " -> " ++ show (toAPos b) --- | Possible next turns.++-- | 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+++-- | board size (number of pieces)+boardSize :: Board -> Int+boardSize (Board _ you other) = IntMap.size you + IntMap.size other+++-- | next complete turns for the active player nextTurns :: Board -> [Turn]-nextTurns board@(you, _)+nextTurns board@(Board _ you _) | lostOneOfThree = [] | otherwise = captureCapture ++ captureStack ++ captureNothing where@@ -119,12 +162,28 @@ 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 (countPieces you) == 0+ lostOneOfThree = minimum (countStacks you) == 0 +-- | next capture moves for the active player nextCaptureMoves :: Board -> [Move]-nextCaptureMoves board@(you, _) = concatMap forPiece (Map.assocs you)+nextCaptureMoves board@(Board who you _) = 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+++{-+nextCaptureMoves :: Board -> [Move]+nextCaptureMoves board@(Board who you _) = concatMap forPiece (IntMap.assocs you)+ where forPiece :: (Position,Piece) -> [Move] forPiece (p, (_, i)) = concatMap downLine $ sixLines p where@@ -132,13 +191,36 @@ downLine [] = [] downLine (a:b) = case atPosition board a of Nothing -> downLine b- Just (True, _) -> []- Just (False, (_, j)) -> [(p, a) | i>=j]+ Just (who', _) | who'==who -> []+ Just (_, (_, j)) -> [(p, a) | i>=j]+-} ++-- | next stacking moves for the active player nextStackingMoves :: Board -> [Move]-nextStackingMoves board@(you, _) = concatMap forPiece (Map.keys you)+nextStackingMoves board@(Board who you _) = foldl' forPiece [] (IntMap.keys you)+ where + (tzaars:tzarras:totts: _) = countStacks you+ forPiece :: [Move] -> Position -> [Move]+ forPiece moves p = 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', _) | who'/=who -> moves+ Just (_, (Tzaar,_)) | tzaars==1 -> moves+ Just (_, (Tzarra,_)) | tzarras==1 -> moves+ Just (_, (Tott, _)) | totts==1 -> moves+ Just (_, _) -> (p,q) : moves+++{-+nextStackingMoves :: Board -> [Move]+nextStackingMoves board@(you, _) = concatMap forPiece (IntMap.keys you) where- (tzaars:tzarras:totts:_) = countPieces you+ (tzaars:tzarras:totts:_) = countStacks you forPiece :: Position -> [Move] forPiece p = concatMap downLine $ sixLines p where@@ -151,61 +233,85 @@ Just (True, (Tzarra,_)) | tzarras==1 -> [] Just (True, (Tott, _)) | totts==1 -> [] Just (True, _) -> [(p, a)]-+-} --- | count the number of pieces of each type in a half-board-countPieces :: HalfBoard -> [Int]-countPieces b - = count 0 0 0 [t | (t,_)<-Map.elems b] +-- | count the number of stacks of each type in a half-board+countStacks :: HalfBoard -> [Int]+countStacks b + = count 0 0 0 (IntMap.elems b) where- count :: Int -> Int -> Int -> [Type] -> [Int]- count !x !y !z (Tzaar:ts) = count (1+x) y z ts- count !x !y !z (Tzarra:ts) = count x (1+y) z ts- count !x !y !z (Tott:ts) = count x y (1+z) ts- count !x !y !z [] = [x,y,z]+ count :: Int -> Int -> Int -> [Piece] -> [Int]+ count !x !y !z ((Tzaar,_):ps) = count (1+x) y z ps+ count !x !y !z ((Tzarra,_):ps) = count x (1+y) z ps+ count !x !y !z ((Tott,_):ps) = count x y (1+z) ps+ count !x !y !z [] = [x,y,z] +{-+countStacks :: HalfBoard -> [Int]+countStacks b = [tzaars, tzarras, totts]+ 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+ +-} +-- | Swaps board positions after the end of a turn+swapBoard :: Board -> Board+swapBoard (Board who you other) = Board (not who) other you --- Creates a board tree for you and opponent. Assumes you have the next turn.+-- | Create a board tree from a board boardTree :: Board -> BoardTree-boardTree board = firstTurn (mkTree True board)- where- mkTree :: Bool -> Board -> BoardTree- mkTree you b- = GameTree (you,if you then b else swapBoard b) - [ (t, mkTree (not you) $ swapBoard $ applyTurn b t) - | t<-nextTurns b]- -- consider single captures only for first move- firstTurn :: BoardTree -> BoardTree - firstTurn (GameTree node branches) = GameTree node branches'- where branches' = [t | t@((m,Nothing), g)<-branches]-+boardTree b + = GameTree b [(t, boardTree (swapBoard $ applyTurn b t)) | t<-nextTurns b] --- | Swaps board positions, i.e. white to black, black to white.-swapBoard :: Board -> Board-swapBoard (a, b) = (b, a)+-- | Consider 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] --- | Swaps board trees, i.e. white to black, black to white. swapBoardTree :: BoardTree -> BoardTree-swapBoardTree (GameTree (you,board) branches) = GameTree (not you,swapBoard board) [ (t, swapBoardTree bt) | (t, bt) <- branches ]+swapBoardTree = mapTree swapBoard --- Querying the state of a board position.+-- | Check for a game tree leaf (i.e. end of game situation)+isEndGame :: GameTree s m -> Bool+isEndGame (GameTree _ branches) = null branches++-- | some auxiliary functions over game trees+-- apply a function to each node+mapTree :: (a->b) -> GameTree a m -> GameTree b m+mapTree f (GameTree x branches) + = GameTree (f x) [(m,mapTree f t) | (m,t)<-branches]++-- apply a function to each edge+mapTree' :: (a->b) -> GameTree s a -> GameTree s b+mapTree' f (GameTree x branches) + = GameTree x [(f m,mapTree' f t) | (m,t)<-branches]+++-- | Query the state of a board position. atPosition :: Board -> Position -> Maybe (Bool,Piece)-atPosition (you,opp) pos - = do { piece<-Map.lookup pos you- ; return (True,piece) +atPosition (Board who you other) pos + = do { piece<-IntMap.lookup pos you+ ; return (who,piece) } `mplus`- do { piece<-Map.lookup pos opp- ; return (False,piece)+ do { piece<-IntMap.lookup pos other+ ; return (not who,piece) } -- | All the lines that form connected positions on the board. connectedPositions :: [[Position]] connectedPositions =+ map (map fromAPos) [ [A1, A2, A3, A4, A5] , [B1, B2, B3, B4, B5, B6] , [C1, C2, C3, C4, C5, C6, C7]@@ -246,9 +352,9 @@ -- | The six lines traveling radially out from a single board position.--- | optimization: this map is memoied lazily -sixLines_memo :: Map Position [[Position]]-sixLines_memo = Map.fromList [(p, radials p) | p<-positions]+-- | optimization: this map should be memoied lazily +sixLines_memo :: IntMap [[Position]] -- Map Position [[Position]]+sixLines_memo = IntMap.fromList [(p, radials p) | p<-positions] where radials p = [r | l<-threeLines p, r<-divide p l, not (null r)] divide a b = [reverse x, y] where (x, _:y) = span (/= a) b@@ -258,14 +364,30 @@ --- | The next board state after a move. Assumes move is valid.+-- | 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 = (Map.insert y piece (Map.delete x a), b')- | otherwise = (a', Map.insert y piece (Map.delete x b))+ | whoX = (IntMap.insert y piece (IntMap.delete x a), b')+ | otherwise = (a', IntMap.insert y piece (IntMap.delete x b)) where- whoX = Map.member x a- whoY = Map.member y a+ whoX = IntMap.member x a+ whoY = IntMap.member y a (typeX, sizeX) | whoX = a!x | otherwise = b!x (_ , sizeY) | whoY = a!y@@ -273,10 +395,11 @@ capture = whoX /= whoY piece | capture = (typeX, sizeX) | otherwise = (typeX, sizeX + sizeY)- a' | capture = Map.delete y a+ a' | capture = IntMap.delete y a | otherwise = a- b' | capture = Map.delete y b+ b' | capture = IntMap.delete y b | otherwise = b+-} -- | The next board state after a complete turn. Assumes turn is valid. applyTurn :: Board -> Turn -> Board@@ -285,25 +408,31 @@ +-- | An empty board+emptyBoard :: Board+emptyBoard = Board True (IntMap.empty) (IntMap.empty)++ -- | The default (non-randomized, non-tournament) starting position. startingBoard :: Board-startingBoard = (Map.fromList whites, Map.fromList blacks)+startingBoard = Board True (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 blacks = map (f Tzaar) bTzaars ++ map (f Tzarra) bTzarras ++ map (f Tott) bTotts- wTzaars = [D3, E3, G4, G5, C5, D6]- wTzarras = [C2, D2, E2, H3, H4, H5, B5, C6, D7]- wTotts = [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]- bTzaars = [C3, C4, F3, G3, E6, F6]- bTzarras = [B2, B3, B4, F2, G2, H2, E7, F7, G6]- bTotts = [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, G7, H6, D4, E5, F4]+ wTzaars = map fromAPos [D3, E3, G4, G5, C5, D6]+ wTzarras = map fromAPos [C2, D2, E2, H3, H4, H5, B5, C6, D7]+ wTotts = map fromAPos [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]+ bTzaars = map fromAPos [C3, C4, F3, G3, E6, F6]+ bTzarras = map fromAPos [B2, B3, B4, F2, G2, H2, E7, F7, G6]+ bTotts = map fromAPos [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, + G7, H6, D4, E5, F4] -- | A randomized starting position randomBoard :: StdGen -> (Board, StdGen) randomBoard rnd - = ((Map.fromList whites, Map.fromList blacks), rnd')+ = (Board True (IntMap.fromList whites) (IntMap.fromList blacks), rnd') where pieces = replicate 6 (Tzaar,1) ++ replicate 9 (Tzarra,1) ++ replicate 15 (Tott,1)@@ -326,3 +455,72 @@ +-- | maximum absolute value of static evaluation +infinity :: Int+infinity = 2^20++------------------------------------------------------------------------+-- | QuickCheck generators+------------------------------------------------------------------------++-- generators for board elements+instance Arbitrary Type where+ arbitrary = elements [Tzaar,Tzarra,Tott]++-- default generator and counter-example shrinker for boards+instance Arbitrary Board where+ arbitrary = sized genBoard++ shrink (Board who you other) + = [Board who you' other | you'<-shrinkHalf you] +++ [Board who you other' | other'<-shrinkHalf other] +++-- helper function to shrink half-boards+-- first try to remove pieces, then reduce heights+shrinkHalf :: HalfBoard -> [HalfBoard]+shrinkHalf b = [IntMap.delete p b | p<-IntMap.keys b] +++ [IntMap.insert p (t,h') b | + (p,(t,h))<-IntMap.assocs b, h'<-[1..h-1]]++++-- a generator for boards+-- size argument is a bound for the total number of pieces+genBoard :: Int -> Gen Board+genBoard n = do ws <- genPieces n'+ bs <- genPieces n'+ positions' <- genShuffle positions+ 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)+ where n' = (min 60 n)`div`2++++genPieces :: Int -> Gen [(Type,Int)]+genPieces n = do pieces <- genShuffle allpieces+ k <- choose (0,n)+ genStacks k (take n pieces)+ where allpieces = [(t,1) | t<-replicate 6 Tzaar ++ + replicate 9 Tzarra ++ + replicate 15 Tott]+ ++-- generate stacks from single pieces+genStacks 0 xs = return xs+genStacks _ [] = return []+genStacks _ [x]= return [x]+genStacks (n+1) xs = do p1@(t1,h1) <- elements xs+ let xs' = delete p1 xs+ p2@(t2,h2) <- elements xs'+ genStacks n ((t1,h1+h2) : delete p2 xs')+ ++-- auxiliary function to shuffle a list+genShuffle :: Eq a => [a] -> Gen [a]+genShuffle [] = return []+genShuffle xs = do x <- elements xs+ xs'<- genShuffle (delete x xs)+ return (x:xs')
src/GUI.hs view
@@ -8,8 +8,8 @@ import Graphics.Rendering.Cairo import Data.Function (on) import Data.Maybe (fromJust)-import qualified Data.Map as Map-import Data.Map (Map, (!))+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap, (!)) import Data.List (minimumBy, sortBy) import Data.IORef import Control.Concurrent@@ -17,18 +17,23 @@ import System.Random 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- { bt :: BoardTree- , history :: [State]+-- | Record to hold the game state+data State = State + { board :: Board -- current board+ , turns :: [Turn] -- valid turns+ , history :: [State] -- undo/redo history , future :: [State]- , stdGen :: StdGen- , ai :: AI- , stage :: Stage+ , stdGen :: StdGen -- random number generator+ , ai :: AI -- ai player+ , stage :: Stage -- selection stage } + data Stage = Start0 -- first turn, single move | Start1 Position@@ -41,36 +46,51 @@ deriving Eq --- a reference to mutable state+-- | A reference to mutable state type StateRef = IORef State --- a state with an empty board (before game start)+-- | A state with an empty board (before game starts) emptyState :: StdGen -> State-emptyState rnd = State { bt = boardTree emptyboard,+emptyState rnd = State { board = emptyBoard,+ turns = [], history = [], future = [], stdGen = rnd, ai = undefined, stage = Finish }- where emptyboard = (Map.empty, Map.empty) --- initial state (at game start)-initState :: Bool -> StdGen -> AI -> State-initState randomstart g ai - = State { bt = boardTree board+-- | Initial game state state +-- | standard non-random board+initState :: StdGen -> AI -> State+initState rnd ai + = State { board = startingBoard , history = []+ -- first turn must be a single capture+ , turns = zip (nextCaptureMoves startingBoard) (repeat Nothing) , future = []- , stdGen = g'+ , stdGen = rnd , ai = ai , stage = Start0 }- where (board, g') | randomstart = randomBoard g- | otherwise = (startingBoard, g) +-- random board+initRandomState :: StdGen -> AI -> State+initRandomState rnd ai+ = State { board = b+ -- first turn must be a single capture+ , turns = zip (nextCaptureMoves b) (repeat Nothing)+ , history = []+ , future = []+ , stdGen = rnd'+ , ai = ai+ , stage = Start0+ }+ where (b, rnd') = randomBoard rnd + -- a record to hold GUI elements data GUI = GUI { mainwin :: Window,@@ -187,7 +207,9 @@ = do s <- readIORef stateRef ai <- getAI gui random <- checkMenuItemGetActive (menu_item_random_start gui)- writeIORef stateRef $ initState random (stdGen s) ai+ writeIORef stateRef $ + if random then initRandomState (stdGen s) ai+ else initState (stdGen s) ai updateWidgets gui stateRef gui `pushMsg` "Ready" @@ -315,40 +337,41 @@ = do -- paint the background boardBg >> paint -- paint the playing area light gray- gray 0.9 >> polyLine [A1, A5, E8, I5, I1, E1] >> closePath >> fill+ gray 0.9 >> polyLine (map fromAPos [A1, A5, E8, I5, I1, E1]) + >> closePath >> fill -- repaint the center with background color- boardBg >> polyLine [D4, D5, E5, F5, F4, E4]>> closePath >> fill+ boardBg >> polyLine (map fromAPos [D4, D5, E5, F5, F4, E4]) + >> closePath >> fill -- draw the grid and coordinates renderGrid -- draw the pieces & highlight selection case stage state of- Start0 -> pieces board >>= renderHeights heights- Start1 p -> pieces board >>= renderHeights heights >> highlight p- Wait0 -> pieces board >>= renderHeights heights- Wait1 p -> pieces board >>= renderHeights heights >> highlight p- Wait2 m -> pieces (applyMove board m) >>= renderHeights heights- Wait3 m p -> pieces (applyMove board m) >>= renderHeights heights - >> highlight p- Wait4 t -> pieces (applyTurn board t) >>= renderHeights heights- Finish -> pieces board >>= renderHeights heights- where GameTree (_,board) _ = bt state+ 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+ where b = board state -- draw the hexagonal grid and edge coordinates renderGrid :: Render () renderGrid = do gray 0 setLineWidth 1- sequence_ [lineFromTo p1 p2 | (p1,p2)<-lines] + sequence_ [lineFromTo (fromAPos p1) (fromAPos p2) | (p1,p2)<-lines] setFontSize 22- sequence_ [do uncurry moveTo $ tr (-10,60) $ boardPosition p- showText (show p) - | p<-[A1,B1,C1,D1,E1,F1,G1,H1,I1]]- sequence_ [do uncurry moveTo $ tr (-10,-50) $ boardPosition p- showText (show p) - | p<-[A5, B6,C7,D8,E8,F8,G7,H6,I5]]+ sequence_ [do uncurry moveTo $ tr (-10,60) $ screenCoordinate p+ showText (show $ toAPos p) + | p<-map fromAPos [A1,B1,C1,D1,E1,F1,G1,H1,I1]]+ sequence_ [do uncurry moveTo $ tr (-10,-50) $ screenCoordinate p+ showText (show $ toAPos p) + | p<-map fromAPos [A5, B6,C7,D8,E8,F8,G7,H6,I5]] where tr (dx,dy) (x,y) = (x+dx,y+dy)- lineFromTo p1 p2 = do uncurry moveTo $ boardPosition p1- uncurry lineTo $ boardPosition p2+ lineFromTo p1 p2 = do uncurry moveTo $ screenCoordinate p1+ uncurry lineTo $ screenCoordinate p2 stroke lines = [(A1,A5), (B1,B6), (C1,C7), (D1,D8), (E1,E4), (E5,E8), (F1,F8), (G1,G7), (H1,H6), (I1,I5),@@ -380,45 +403,38 @@ -- draw a polygonal line polyLine :: [Position] -> Render ()-polyLine (p:ps) = do uncurry moveTo $ boardPosition p- sequence_ [uncurry lineTo $ boardPosition p'|p'<-ps]+polyLine (p:ps) = do uncurry moveTo $ screenCoordinate p+ sequence_ [uncurry lineTo $ screenCoordinate p'|p'<-ps] -- highlight a position-highlight :: Position -> Render ()-highlight p = do setSourceRGBA 1 0 0 0.5- setLineWidth 4- newPath- uncurry (ring 1.5) $ boardPosition p+highlight :: Position -> Render ()+highlight p =+ do setSourceRGBA 1 0 0 0.5+ setLineWidth 4+ newPath+ uncurry (disc 1.5) (screenCoordinate p) -data PieceColor = White | Black deriving (Eq,Show) -- render all pieces in the board -- returns the original board for futher use pieces :: Board -> Render Board-pieces board@(whites,blacks) +pieces board = do setLineWidth 2 mapM_ piece ps return board -- sort pieces by reverse position to draw from back to front where ps = sortBy cmp $ - zip (repeat White) (Map.assocs whites) ++- zip (repeat Black) (Map.assocs blacks)- cmp (_, (x,_)) (_, (y,_)) = compare y x+ zip (repeat White) (IntMap.assocs (whites board)) +++ zip (repeat Black) (IntMap.assocs (blacks board))+ cmp (_,(x,_)) (_,(y,_)) = compare y x -piece :: (PieceColor,(Position,(Type,Int))) -> Render ()+piece :: (PieceColor,(Position,Piece))-> Render () piece (c,(p,(t,size))) = stack size yc- where (xc,yc)= boardPosition p- (chipColor, lineColor, crownColor) - = case c of- White-> (setSourceRGB 1 1 1, - setSourceRGB 0 0 0, - setSourceRGB 0.25 0.25 0)- Black-> (setSourceRGB 0 0 0, - setSourceRGB 1 1 1, - setSourceRGB 1 0.75 0)+ where (xc,yc)= screenCoordinate p+ (chipColor, lineColor, crownColor) = pieceColors c stack 0 y = case t of Tott -> return () Tzarra -> crownColor >> disc 0.4 xc y@@ -428,8 +444,7 @@ stack n y | n>0 = do chipColor >> disc 1 xc y lineColor >> ring 1 xc y- stack (n-1) $ if n>1 then y-8 else y-+ stack (n-1) $ if n>1 then y-10 else y disc :: Double -> Double -> Double -> Render ()@@ -439,24 +454,40 @@ ring r x y = arc x y (r*33) 0 (2*pi) >> stroke +-- (chip color, line color, crown color)+pieceColors :: PieceColor -> (Render (), Render (), Render ())+pieceColors White = (setSourceRGB 1 1 1, + setSourceRGB 0 0 0, + setSourceRGB 0.35 0.25 0)+pieceColors Black = (setSourceRGB 0 0 0, + setSourceRGB 1 1 1,+ setSourceRGB 0.75 0.75 0.75)+++ -- label each position with the stack height -- ignore single piece stacks renderHeights :: Bool -> Board -> Render ()-renderHeights b (whites,blacks)- = when b $ do setSourceRGB 1 0 0 - setFontSize 36- mapM_ renderHeight (Map.assocs whites)- mapM_ renderHeight (Map.assocs blacks)+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-10) y- showText (show h)+ | h>1 = do moveTo (x-15) (y+12-8*dy)+ showText txt | otherwise = return ()- where (x,y) = boardPosition p+ 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@@ -466,7 +497,7 @@ deviceToUser x y) let (p, d) = minimumBy (compare `on` snd) [(p, (xu - x')^2 + (yu - y')^2) - | (p, (x', y')) <- Map.assocs boardPositions ]+ | (p, (x', y')) <- IntMap.assocs screenCoordinates ] return (if d<900 then Just p else Nothing) @@ -474,35 +505,34 @@ -- dispatch a button click on a board position selectPosition :: GUI -> StateRef -> Position -> IO () selectPosition gui stateRef p- = do s<-readIORef stateRef - let GameTree _ branches = bt s- let turns = fst $ unzip branches+ = do s <- readIORef stateRef + -- valid turns from this position case stage s of- Start0 | notNull [p0 | ((p0, _), _)<-turns, p0==p] -> + Start0 | notNull [p0 | ((p0, _), _)<-turns 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, m==(p0,p)] -> + Start1 p0 | notNull [m | (m, _)<- turns s, m==(p0,p)] -> dispatchTurn gui stateRef s ((p0,p),Nothing) ---- Wait0 | notNull [p0 | ((p0, _), _)<-turns, p0==p] -> + Wait0 | notNull [p0 | ((p0, _), _)<-turns 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, m==(p0,p)] -> + 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, m==m', p0==p] -> + 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 -> dispatchTurn gui stateRef s t+ Wait3 m p0 | t`elem`turns s -> dispatchTurn gui stateRef s t where t = (m, Just (p0, p)) _ -> return () where cv = canvas gui@@ -511,55 +541,68 @@ dispatchTurn :: GUI -> StateRef -> State -> Turn -> IO () dispatchTurn gui stateRef s t- | null branches' -- white wins- = let s' = s { stage = Finish, - bt = swapBoardTree bt', - stdGen = g }+ | 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}+ = do { writeIORef stateRef $ s {stage = Wait4 t, turns = []} ; redrawCanvas (canvas gui) ; gui `pushMsg` "Thinking..." ; forkIO child ; return () }- where- child = if null branches'' then- let s'= s { stage = Finish, - bt = bt'', - stdGen = g }- in do writeIORef stateRef s'- redrawCanvas (canvas gui)- gui `pushMsg` "Black wins"- else- let s' = s { stage = Wait0,- bt = bt'',- stdGen = g- }- in do writeIORef stateRef s'- redrawCanvas (canvas gui)- gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t')- + 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 Turn: " ++ show t'+ Nothing -> error ("Invalid AI move: " ++ show t') Just a -> a+-} -boardPosition :: Position -> (Double,Double)-boardPosition p = boardPositions!p+-- screen coordinate of a board position+screenCoordinate :: Position -> (Double,Double)+screenCoordinate p = screenCoordinates!p -boardPositions :: Map Position (Double,Double)-boardPositions - = Map.fromList+screenCoordinates :: IntMap (Double,Double)+screenCoordinates + = IntMap.fromList $+ map (\(p,q) -> (fromAPos p, q)) [ (A1, p (-4) (-2)) , (A2, p (-4) (-1)) , (A3, p (-4) ( 0))
src/Tests.hs view
@@ -8,131 +8,64 @@ import AI.Utils import AI.Eval import Test.QuickCheck-import qualified Data.Map as Map-import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet import List (delete, nub, sort) --- generators for board elements-instance Arbitrary Type where- arbitrary = elements [Tzaar,Tzarra,Tott] -instance Arbitrary Position where- arbitrary = elements positions---- a new type isomorphic to boards for testing purposes-newtype TestBoard = TestBoard Board deriving Show---- default generator and counter-exemple shrinker for boards-instance Arbitrary TestBoard where- arbitrary = sized genBoard-- shrink (TestBoard (w,b)) - = [TestBoard (w',b) | w'<-shrinkHalf w] ++- [TestBoard (w,b') | b'<-shrinkHalf b] ----- helper function to shrink half-boards--- first try to remove pieces, then reduce heights-shrinkHalf :: HalfBoard -> [HalfBoard]-shrinkHalf b = [Map.delete p b | p<-Map.keys b] ++- [Map.insert p (t,h') b | - (p,(t,h))<-Map.assocs b, h'<-[1..h-1]]------ a generator for boards--- size argument is a bound for the total number of pieces-genBoard :: Int -> Gen TestBoard-genBoard n = do ws <- genPieces n'- bs <- genPieces n'- positions' <- genShuffle positions- let whites = zip (take n' positions') ws- let blacks = zip (drop n' positions') bs- return $ TestBoard (Map.fromList whites, - Map.fromList blacks)- where n' = (min 60 n)`div`2----genPieces :: Int -> Gen [(Type,Int)]-genPieces n = do pieces <- genShuffle allpieces- k <- choose (0,n)- genStacks k (take n pieces)- where allpieces = [(t,1) | t<-replicate 6 Tzaar ++ - replicate 9 Tzarra ++ - replicate 15 Tott]- ---- generate stacks from single pieces-genStacks 0 xs = return xs-genStacks _ [] = return []-genStacks _ [x]= return [x]-genStacks (n+1) xs = do p1@(t1,h1) <- elements xs- let xs' = delete p1 xs- p2@(t2,h2) <- elements xs'- genStacks n ((t1,h1+h2) : delete p2 xs')-- ---- auxiliary function to shuffle a list-genShuffle :: Eq a => [a] -> Gen [a]-genShuffle [] = return []-genShuffle xs = do x <- elements xs- xs'<- genShuffle (delete x xs)- return (x:xs')--quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n}) - --------------------------------------------------------------------------- -- Quickcheck properties --------------------------------------------------------------------------- -- a capture reduces the number of pieces by one-prop_capture_moves :: TestBoard -> Bool-prop_capture_moves (TestBoard b)- = and [1+bdsize b' == bdsize b |+prop_capture_moves :: Board -> Bool+prop_capture_moves b+ = and [1+boardSize b' == boardSize b | m<-nextCaptureMoves b, let b' = applyMove b m] -- a stacking reduces the number of pieces by one-prop_stacking_moves1 :: TestBoard -> Bool-prop_stacking_moves1 (TestBoard b)- = and [1+bdsize b' == bdsize b |+prop_stacking_moves1 :: Board -> Bool+prop_stacking_moves1 b+ = and [1+boardSize b' == boardSize b | m<-nextStackingMoves b, let b' = applyMove b m] --- a stacking mantains the sum of pieces heights-prop_stacking_moves2 :: TestBoard -> Bool-prop_stacking_moves2 (TestBoard b)- = and [ heights (fst b') == heights (fst b) &&- heights (snd b') == heights (snd b) | +-- stacking mantains the sum of pieces heights of the active player+-- and does not change the pieces of the other player+prop_stacking_moves2 :: Board -> Bool+prop_stacking_moves2 b+ = and [ heights (active b') == heights (active b) && inactive b' == inactive b | m <- nextStackingMoves b, let b'=applyMove b m]- where heights b = sum [h | (_,h)<-Map.elems b]+ where heights b = sum [h | (_,h)<-IntMap.elems b] --------------------------------------------------------------------------- -- some properties of the AI code --------------------------------------------------------------------------- +{- -- static evaluation respects the zero-sum property-prop_zero_sum :: Bool -> TestBoard -> Property-prop_zero_sum who (TestBoard b) - = admissible b ==> eval (who,b) - eval (not who, swapBoard b) == 0-+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 :: TestBoard -> Property-prop_value_bounds (TestBoard b) - = not (white_lost b) && not (black_lost b) ==> score > -inf && score < inf- where score = value b+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 --- end game positions give plus/minus infinity scores-prop_black_lost :: TestBoard -> Property-prop_black_lost (TestBoard b) - = not (white_lost b) && black_lost b ==> (value b==inf) +-- 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 -prop_white_lost :: TestBoard -> Property-prop_white_lost (TestBoard b) - = not (black_lost b) && white_lost b ==> (value b == (-inf))+prop_active_lost :: Board -> Property+prop_active_lost b+ = not (inactive_lost b) && active_lost b ==> + static_eval b == (-infinity) @@ -140,28 +73,29 @@ -- parameters: number of pieces, pruning depth and breadth prop_alpha_beta :: Int -> Int -> Int -> Property prop_alpha_beta npieces depth breadth- = forAllShrink (resize npieces arbitrary) shrink $ \(TestBoard b) ->- not (white_lost b) ==>+ = forAllShrink (resize npieces arbitrary) shrink $ \b ->+ not (active_lost b) ==> let bt = mkTree depth breadth b- in minimax_ab (-inf) inf bt == minimax bt+ in minimax_ab (-infinity) infinity bt == minimax bt --- the move computed by extended alpha-beta pruning is principal+-- 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 $ \(TestBoard b) ->- not (white_lost b) ==> + = forAllShrink (resize npieces arbitrary) shrink $ \b ->+ not (active_lost b) ==> let bt = mkTree depth breadth b- (m,v)= minimaxMove_ab (-inf) inf bt+ (m,v)= minimaxMove_ab (-infinity) infinity bt bt' = treeMove m bt in minimax bt' == -v mkTree :: Int -> Int -> Board -> GameTree Int Turn-mkTree depth breadth board = prunedepth depth $ - prunebreadth_asc breadth $ - mapTree eval $ +mkTree depth breadth board = pruneDepth depth $ + pruneBreadth breadth $ + lowFirst $+ mapTree static_eval $ boardTree board @@ -169,45 +103,34 @@ treeMove m (GameTree _ branches) = head [t | (m',t)<-branches, m'==m] ---- -- correctness of the zone of control computation -- the zone of control is the set of pieces -- that can be captured in a turn (one or two moves)-prop_zoc_correct1 :: TestBoard -> Bool-prop_zoc_correct1 (TestBoard b) = pos == pos'+prop_zoc_correct :: Board -> Bool+prop_zoc_correct b = pos == pos' where moves1 = nextCaptureMoves b moves2 = concat [nextCaptureMoves (applyMove b m) | m<-moves1]- pos = Set.fromList (map snd moves1 ++ map snd moves2)- pos'= Map.keysSet (zoneOfControl (>=) b)--prop_zoc_correct2 :: TestBoard -> Bool-prop_zoc_correct2 (TestBoard b) - = zoc_gt `Map.isSubmapOf` zoc_geq- where zoc_geq = zoneOfControl (>=) b- zoc_gt = zoneOfControl (>) b+ pos = IntSet.fromList (map snd moves1 ++ map snd moves2)+ pos'= IntMap.keysSet (zoneOfControl b) -- helper functions to filter boards, etc.--- admissible boards: at most one loser-admissible, white_lost, black_lost :: Board -> Bool-admissible b = not (white_lost b && black_lost b)+-- "admissible" boards: no winner yet+admissible :: Board -> Bool+admissible b + = not (active_lost b) && not (inactive_lost b) -white_lost b = null (nextCaptureMoves b) || pieceTypes (fst b)/= 3-black_lost = white_lost . swapBoard+active_lost, inactive_lost :: Board -> Bool+active_lost b = null (nextCaptureMoves b) || pieceTypes (active b)/= 3+inactive_lost = active_lost . swapBoard -- number of piece types in a half-board pieceTypes :: HalfBoard -> Int-pieceTypes b = length $ nub $ map fst $ Map.elems b+pieceTypes b = length $ nub $ map fst $ IntMap.elems b --- board size (number of pieces)-bdsize :: Board -> Int-bdsize (w,b) = Map.size w + Map.size b -- run all tests@@ -218,12 +141,12 @@ 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_black_lost", quickCheck prop_black_lost)- , ("prop_white_lost", quickCheck prop_white_lost)- , ("prop_zoc_correct1", quickCheck prop_zoc_correct1)- , ("prop_zoc_correct2", quickCheck prop_zoc_correct2)+ , ("prop_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",@@ -234,3 +157,6 @@ quickCheck (prop_alpha_beta_move 15 6 5)) ] +++quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n})
src/Tournament.hs view
@@ -11,43 +11,39 @@ -- plays 2 games with (either strategy first) and sums the results -- result is 1 , 0 or -1 according to the relative comparision playMatch :: AI -> AI -> Board -> StdGen -> IO Int-playMatch p1 p2 startboard rndgen - = playMatch' 1 (boardTree startboard) rndgen p1 p2+playMatch p1 p2 b rndgen + = playMatch' 1 (startBoardTree b) rndgen p1 p2 playMatch' :: Int -> BoardTree -> StdGen -> AI -> AI -> IO Int-playMatch' n bt@(GameTree _ branches) rnd p1 p2- | null branches -- first player can't play: second player wins- = return (-1)- | otherwise - = do putStrLn (show n ++ ". " ++ name p1 ++ ":\t" ++ showTurn t)- liftM negate $ playMatch' (n+1) bt' rnd' p2 p1+playMatch' n bt@(GameTree board branches) rnd p1 p2+ | null branches = 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' = swapBoardTree $ head [bt' | (t',bt')<-branches, t'==t]- --k = length branches+ bt' = boardTree $ swapBoard (applyTurn board t) + -- bt' = head [bt' | (t',bt')<-branches, t'==t] -- compare two strategies on random boards playAIs :: AI -> AI -> [Board] ->StdGen -> IO () playAIs p1 p2 boards rnd - = do rs<-sequence ([do header i- r<-playMatch p1 p2 b rnd - footer- return r- | (i,b)<-zip [1..] boards] ++- [do header i- r<-playMatch p2 p1 b rnd- footer- return (-r)- | (i,b)<- zip [n+1..] boards- ])- let won = length [r | r<-rs, r>0]- let lost= length [r | r<-rs, r<0]- let score = sum rs- putStrLn (name p1 ++ " vs " ++ name p2 ++ ": " - ++ show score ++ " (" - ++ show won ++ " matches won and " - ++ show lost ++ " lost)")+ = do rs1<-sequence [do { header i+ ; r<-playMatch p1 p2 b rnd+ ; footer+ ; return r } | (i,b)<-zip [1..] boards] + rs2<-sequence [do { header i+ ; r<-playMatch p2 p1 b rnd+ ; footer+ ; return (-r) } | (i,b)<- zip [n+1..] boards]+ let rs = rs1++rs2+ let won = length [r | r<-rs, r>0]+ let lost= length [r | r<-rs, r<0]+ let score = sum rs+ putStrLn (name p1 ++ " vs " ++ name p2 ++ ": " + ++ show score ++ " (" + ++ show won ++ " matches won and " + ++ show lost ++ " lost)") where n = length boards header i = putStrLn ("Match " ++ show i ++ "/" ++ show (2*n)) footer = putStrLn (replicate 80 '-')