diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -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 diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -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 + diff --git a/src/AI.hs b/src/AI.hs --- a/src/AI.hs +++ b/src/AI.hs @@ -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] diff --git a/src/AI/Eval.hs b/src/AI/Eval.hs --- a/src/AI/Eval.hs +++ b/src/AI/Eval.hs @@ -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 +-} diff --git a/src/AI/Lame.hs b/src/AI/Lame.hs --- a/src/AI/Lame.hs +++ b/src/AI/Lame.hs @@ -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 diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs --- a/src/AI/Minimax.hs +++ b/src/AI/Minimax.hs @@ -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 - --} diff --git a/src/AI/Utils.hs b/src/AI/Utils.hs --- a/src/AI/Utils.hs +++ b/src/AI/Utils.hs @@ -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 + diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -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') diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -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)) diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -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}) diff --git a/src/Tournament.hs b/src/Tournament.hs --- a/src/Tournament.hs +++ b/src/Tournament.hs @@ -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 '-')