hstzaar 0.9.3 → 0.9.4
raw patch · 12 files changed
+633/−661 lines, 12 filesdep +arraydep +hashabledep +mtldep ~basedep ~random
Dependencies added: array, hashable, mtl, unordered-containers, vector
Dependency ranges changed: base, random
Files
- RELEASE-NOTES +4/−3
- hstzaar.cabal +12/−8
- src/AI.hs +33/−38
- src/AI/Eval.hs +29/−32
- src/AI/Gametree.hs +30/−16
- src/AI/Minimax.hs +102/−97
- src/Board.hs +179/−187
- src/GUI.hs +117/−127
- src/Main.hs +18/−38
- src/Serialize.hs +30/−40
- src/Tests.hs +63/−61
- src/Tournament.hs +16/−14
RELEASE-NOTES view
@@ -1,6 +1,7 @@-0.9.3 11/03/2013-- added an command line option to ask for an AI move for- a given board configuration+0.9.4 27/05/2016+- lots of code optimizations in board & AI search+- updated .cabal file to pass RTS flag -N automatically;+ should now run parallel AIs using multiple CPUs by default 0.9.2 30/08/2012 - removed bogus dependency on haskell98 package
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.9.3+version: 0.9.4 category: Game @@ -25,24 +25,28 @@ data-files: hstzaar.glade extra-source-files:- RELEASE-NOTES + RELEASE-NOTES executable hstzaar hs-source-dirs: src main-is: Main.hs other-modules: GUI Serialize Board AI AI.Gametree AI.Eval AI.Minimax Tournament Tests build-depends:- base >= 4 && <5,+ base >= 4.7 && <5, filepath >= 1.1, directory >= 1.0,+ array >= 0.5, containers,+ unordered-containers,+ hashable,+ mtl >= 2,+ vector >= 0.10, parallel >= 2.0,- gtk >=0.11, - cairo >= 0.11, + gtk >=0.11,+ cairo >= 0.11, glade >= 0.11,- random >= 1.0.0 && < 1.1,+ random >= 1.0.0, QuickCheck >= 2.1, xml >= 1.3 - ghc-options: -threaded -rtsopts - ghc-prof-options: -prof -auto-all + ghc-options: -threaded -rtsopts -with-rtsopts=-N
src/AI.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiParamTypeClasses #-} -- -- Library of AI players --@@ -10,68 +11,62 @@ import Data.Maybe(catMaybes) import AI.Gametree import AI.Minimax-import AI.Eval +import AI.Eval +import Control.Monad.State --- | instance the gametree class for TZAAR -instance Gametree Board where- children b = [applyMove m b | m<-nextMoves b]- is_terminal b = null (nextMoves b) --- | An AI play strategy --- takes a board and pseudo-random generator --- yields evaluation, next move and new random generator-type Playing = Board -> StdGen -> (Int, Move, StdGen)+-- | instance the transition system for TZAAR games+instance Transitions Board Move where+ actions = nextMoves+ transition = applyMove +-- | An AI play strategy+-- allows monad for pseudo-random computations+-- (current strategies don't need it)+type Strategy = Board -> State StdGen (Move, Value)+ -- | An AI player. data AI = AI { name :: String -- ^ Unique name , description :: String -- ^ Brief description of AI.- , playing :: Playing -- ^ The play strategy.+ , strategy :: Strategy -- ^ The AI strategy. } --+ {- aiLevels :: [AI] aiLevels = catMaybes [lookupAI label aiPlayers | label<-list]- where list = ["nscout_simple_1", + where list = ["nscout_simple_1", "nscout_simple_3",- "nscout_full_1", - "nscout_full_3", - "nscout_full_6", - "pscout_full_3", + "nscout_full_1",+ "nscout_full_3",+ "nscout_full_6",+ "pscout_full_3", "pscout_full_6"]-+-}+aiLevels = aiPlayers lookupAI :: String -> [AI] -> Maybe AI-lookupAI label ai_list - = case [ai | ai<-ai_list, name ai==label] of +lookupAI label ai_list+ = case [ai | ai<-ai_list, name ai==label] of [] -> Nothing (ai : _) -> Just ai aiPlayers :: [AI]-aiPlayers = do (txt0,txt1,strat) <- list- (val,txt2) <- zip [simple_val, full_val] ["simple", "full"]- ply <- [1..9]+aiPlayers = do (txt0, txt1, search) <- searches+ (txt2, valf) <- valuations+ ply <- [1..6] let label = txt0 ++ "_" ++ txt2 ++ "_" ++ show ply let desc = txt1 ++ " " ++ txt2 ++ " valuation, ply " ++ show ply return AI { name = label- , description = desc- , playing = play (strat val ply)+ , description = desc+ , strategy = return . searchMove (search valf) ply }- where list = [ ("nmax", "Negamax", negamax_alpha_beta),- ("nscout", "Negascout", negascout), - ("pscout", "Parallel negascout", jamboree)- ]- -play strat b rndgen - | m `elem` nextMoves b = (score, m, rndgen)- | otherwise = error "panic: AI gave invalid move!"- where vpos = strat b- score = value vpos- -- next move in principal variation- m = (reverse $ moves $ unvalued vpos) !! move b-+ where searches = [ ("nmax", "Negamax", alphaBeta)+ , ("nscout", "Negascout", negascout)+ , ("pscout", "Parallel Negascout", jamboree)+ ]+ valuations = [ ("simple", simpleVal), ("full", fullVal)]
src/AI/Eval.hs view
@@ -1,58 +1,55 @@-{-# LANGUAGE BangPatterns #-} -- -- Static evaluation functions for board positions ---module AI.Eval (simple_val, full_val) where-import Board-import AI.Gametree+module AI.Eval (+ simpleVal,+ fullVal+ ) where +import Board+import AI.Gametree+import AI.Minimax+import qualified Data.Vector.Unboxed as Vec -- simple static board valuation (material score only)-simple_val :: Valuation Board-simple_val b = if null (nextMoves b) then lost else material b+simpleVal :: Board -> Value+simpleVal b = if endGame b then (-maxBound) else material b -- better static board valuation (material and positional scores)-full_val :: Valuation Board-full_val b = if null (nextMoves b) then lost else material b + positional b -+fullVal :: Board -> Value+fullVal b = if endGame b then (-maxBound) else material b + positional b --- score for a losing position--- this should be strictly greater than minBound to avoid "boundary" issues-lost :: Int-lost = minBound`div`2- -- | Material score--- * multiply sum of heights by counts +-- * multiply sum of heights by counts -- * height weights for kinds with lowest counts-material :: Board -> Int+material :: Board -> Value {-# INLINE material #-}-material b = (sum [(30-n)*h | (n,h)<-zip counts heights] -- sum [(30-n)*h | (n,h)<-zip counts' heights'])- where - -- stacks counts by piece kinds for each player +material b = fromIntegral+ (Vec.sum (Vec.zipWith (\n h -> (30-n)^2*h) counts heights) -+ Vec.sum (Vec.zipWith (\n h -> (30-n)^2*h) counts' heights'))+ where+ -- stacks counts by piece kinds for each player counts = activeCounts b counts'= inactiveCounts b -- sum of heights by piece kinds heights = activeHeights b heights'= inactiveHeights b- + -- | Positional score--- for each kind, count opponent's pieces in each player's zone of control -positional :: Board -> Int+-- for each kind, count opponent's pieces in each player's zone of control+positional :: Board -> Value {-# INLINE positional #-}-positional b = (sum [pw*m`div`n | (n,m)<-zip counts' zoc_counts] -- sum [pw*m`div`n | (n,m)<-zip counts zoc_counts'])- where +positional b = fromIntegral+ (Vec.sum (Vec.zipWith (\n m -> pw*m`quot`n) counts' zoc_counts) -+ Vec.sum (Vec.zipWith (\n m -> pw*m`quot`n) counts zoc_counts'))+ where counts = activeCounts b counts'= inactiveCounts b -- zone of control of each player zoc = zoneOfControl (active b) (pieces b) zoc'= zoneOfControl (inactive b) (pieces b) -- count pieces in each zone of control- zoc_counts= countStacks (inactive b) zoc- zoc_counts'= countStacks (active b) zoc'- pw = 100---+ zoc_counts = Vec.fromList $ countStacks (inactive b) zoc+ zoc_counts'= Vec.fromList $ countStacks (active b) zoc'+ pw = 1000
src/AI/Gametree.hs view
@@ -1,20 +1,35 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+ ----- Type class for traversing AI game trees--- auxiliary definitions for labeling with static valuations --- +-- Traversing game trees+-- auxiliary definitions for labeling with static valuations+-- module AI.Gametree where --- | a type class for gametrees --- parametrized by node type-class Gametree p where- children :: p -> [p] -- list of move, position- is_terminal :: p -> Bool- is_terminal = null . children -- default definition+import Data.Function (on)+import Data.List(minimumBy) --- | type for valuation functions -type Valuation a = a -> Int+-- | a type class for labelled transition systems+-- i.e. game positions and moves+class Transitions s l | s -> l where+ actions :: s -> [l] -- next labels from a state+ transition :: l -> s -> s -- transition from a state +-- | check if a state is terminal+-- i.e. has no actions+isTerminal :: Transitions s l => s -> Bool+isTerminal = null . actions +-- | immediate state successors+successors :: Transitions s l => s -> [s]+successors s = [transition l s | l <- actions s]++-- | immediate successors labelled by actions+transitions :: Transitions s l => s -> [(l,s)]+transitions s = [(l, transition l s) | l <- actions s]+++{- -- | a pair of something with a strict integer valuation -- supporting equality, ordering and limited arithmetic on valuation data Valued a = Valued { value :: !Int, unvalued :: a } deriving Show@@ -22,7 +37,7 @@ instance Functor Valued where fmap f (Valued v x) = Valued v (f x) --- | apply a valuation +-- | apply a valuation valued :: Valuation a -> a -> Valued a valued f x = Valued (f x) x @@ -32,11 +47,11 @@ instance Eq (Valued a) where x == y = value x==value y- + instance Ord (Valued a) where compare x y = compare (value x) (value y)- + -- some instances of numeric type class (only negate and fromInteger) instance Num (Valued a) where (+) = undefined@@ -52,5 +67,4 @@ infix 6 $+ ($+) :: Int -> Valued a -> Valued a k $+ x = revalue (+k) x--+-}
src/AI/Minimax.hs view
@@ -1,133 +1,138 @@-{-# LANGUAGE BangPatterns #-}-module AI.Minimax ( negamax- , negamax_alpha_beta- , negascout- , jamboree- ) where+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} -import Board+module AI.Minimax+ ( + Value+ , searchMove+ , negamax+ , alphaBeta+ , negascout+ , jamboree+ ) where+ import AI.Gametree-import Control.Parallel.Strategies +import Data.List (minimumBy, maximumBy)+import Data.Function (on)+import Control.Parallel.Strategies +-- | a type for game position valuations;+-- simply a wrapper newtype over integers+newtype Value = Value Int deriving (Eq, Ord, Enum, Bounded,+ Num, Real, Integral, Show, Read) --- | Naive negamax algorithm (no prunning)--- wrapper-negamax :: Gametree p => Valuation p -> Int -> p -> Valued p-negamax node_value depth p = negamax' depth p+++-- compute best move using some search function+-- undefined for terminal positions+searchMove :: Transitions s l =>+ (Value -> Value -> Int -> s -> Value)+ -> Int -> s -> (l, Value)+searchMove abSearch depth s = cmx (minBound+1) first (transitions s) where- -- worker- negamax' d p- | d==0 || is_terminal p = valued node_value p- | otherwise = negate $ minimum [negamax' d p' | p'<-children p]- where d' = d-1+ first = head (actions s)+ cmx !alpha best [] = (best, alpha)+ cmx !alpha best ((l,s):rest) = cmx alpha' best' rest+ where !v = - abSearch (-maxBound) (-alpha) (depth-1) s+ !alpha' = if v>alpha then v else alpha+ !best' = if v>alpha then l else best --- | Negamax with alpha-beta prunning --- wrapper-negamax_alpha_beta :: Gametree p => Valuation p -> Int -> p -> Valued p-negamax_alpha_beta node_value depth p- = let a = fromIntegral (minBound+1 :: Int) - b = fromIntegral (maxBound :: Int) - in alpha_beta' depth a b p++-- | Naive negamax algorithm (no alpha-beta prunning)+-- for specification only; use alphaBeta instead+negamax :: Transitions s l => (s -> Value) -> Int -> s -> Value+negamax valf = negamaxAux where- -- worker- alpha_beta' d alfa beta p- | d==0 || is_terminal p = valued node_value p - | otherwise = cmx alfa (children p)- where - d' = d-1- cmx alfa [] = alfa- cmx alfa (p:ps) - | a'>=beta = a'- | otherwise = cmx (max a' alfa) ps- where a' = negate $ alpha_beta' d' (negate beta) (negate alfa) p+ -- recursive worker function+ negamaxAux d s+ | d==0 || isTerminal s = valf s+ | otherwise = - minimum [negamaxAux (d-1) s' | s' <- successors s] --- | Negascout search--- wrapper-negascout :: Gametree p => Valuation p -> Int -> p -> Valued p-negascout node_value depth p- = let a = fromIntegral (minBound+1 :: Int) - b = fromIntegral (maxBound :: Int) - in negascout' node_value depth a b p+-- compute minimax value using Negamax with alpha-beta prunning+alphaBeta :: Transitions s l =>+ (s -> Value) -> Value -> Value -> Int -> s -> Value+alphaBeta valf alpha beta depth s+ | depth==0 || isTerminal s = valf s+ | otherwise = cmx alpha (successors s)+ where+ cmx !alpha [] = alpha+ cmx !alpha (p:ps)+ | a'>=beta = a'+ | otherwise = cmx (max a' alpha) ps+ where a' = - alphaBeta valf (-beta) (-alpha) (depth-1) p --- worker -negascout' node_value d alfa beta p- | d==0 || is_terminal p = valued node_value p - | d==1 = valued (negate . node_value) p0 -- short-circuit for depth 1+++++-- Negascout search+-- worker function+negascout :: Transitions s l =>+ (s -> Value) -> Value -> Value -> Int -> s -> Value+negascout valf alpha beta depth s+ | depth==0 || isTerminal s = valf s+ | depth==1 = - valf s0 -- short-circuit for depth 1 | b >= beta = b- | otherwise = scout (max alfa b) b ps+ | otherwise = scout (max alpha b) b succs where- d' = d-1- ps = children p- p0 = unvalued $ minimum $ map (valued node_value) ps- -- p0 = estimate_best node_value ps -- child with best static score- b = negate $ negascout' node_value d' (negate beta) (negate alfa) p0 -- full search estimate- - scout !alfa !b [] = b- scout !alfa !b (p:ps)+ succs = successors s+ s0 = minimumBy (compare`on`valf) succs+ -- child with best static score+ b = - negascout valf (-beta) (-alpha) (depth-1) s0+ -- full search estimate for the best child++ scout !alpha !b [] = b+ scout !alpha !b (p:ps) | s>=beta = s- | otherwise = scout alfa' b' ps- where s = negate $ negascout' node_value d' (negate (1$+alfa)) (negate alfa) p- s' | s>alfa = negate $ - negascout' node_value d' (negate beta) (negate alfa) p+ | otherwise = scout alpha' b' ps+ where s = - negascout valf (-(1+alpha)) (-alpha) (depth-1) p+ s' | s>alpha = - negascout valf (-beta) (-alpha) (depth-1) p | otherwise = s- alfa' = max alfa s'+ alpha' = max alpha s' b' = max b s'- ++ -- | Parallel negascout, aka "Jamboree" -- | result of each scout test data Result a b = Cutoff a -- beta cutoff found | Search b -- do a full search- | OK -- test suceeded- - -jamboree :: Gametree p => Valuation p -> Int -> p -> Valued p-jamboree node_value depth p - = let a = fromIntegral (minBound+1 :: Int) - b = fromIntegral (maxBound :: Int) - in jamboree' node_value depth a b p + | OK -- test suceeded --- worker-jamboree' node_value d alfa beta p- | d<=1 = negascout' node_value d alfa beta p+++jamboree :: Transitions s l =>+ (s -> Value) -> Value -> Value -> Int -> s -> Value+jamboree valf alpha beta depth p+ | depth<=1 = negascout valf alpha beta depth p -- use sequencial version for low depth- | is_terminal p = valued node_value p -- terminal node?- | b >= beta = b -- 1st child failed high+ | isTerminal p = valf p -- terminal node?+ | b >= beta = b -- 1st child failed high | otherwise = cutoff [] (map scout ps `using` parList rseq)- where - d' = d-1- ps = children p - p0 = unvalued $ minimum $ map (valued node_value) ps -- best child- - b = negate $ jamboree' node_value d' (negate beta) (negate alfa) p0 -- full search estimate- alfa' = max alfa b+ where+ ps = successors p+ p0 = minimumBy (compare`on`valf) ps -- estimated best child+ b = - jamboree valf (-beta) (-alpha) (depth-1) p0 -- full search estimate+ alpha' = max alpha b - scout p - | s >= beta = Cutoff s - | s > alfa' = Search p+ scout p+ | s >= beta = Cutoff s+ | s > alpha' = Search p | otherwise = OK- where s = negate $ jamboree' node_value d' (negate (1$+alfa')) (negate alfa') p+ where s = - jamboree valf (-(1+alpha')) (-alpha') (depth-1) p -- null window search -- join results of parallel scouts cutoff _ (Cutoff s : rs) = s cutoff ps (Search p : rs) = cutoff (p:ps) rs cutoff ps (OK : rs) = cutoff ps rs- cutoff ps [] = search alfa' b ps+ cutoff ps [] = search alpha' b ps -- sequential full search for scout failures- search !alfa !b [] = b- search !alfa !b (p : ps) + search !alpha !b [] = b+ search !alpha !b (p : ps) | s >= beta = s- | otherwise = search (max s alfa) (max s b) ps- where s = negate $ jamboree' node_value d' (negate beta) (negate alfa) p------ | estimate best move using static evaluation--- estimate_best :: Valuation p -> [p] -> p --- estimate_best node_value = minimumBy cmp --- where cmp p p' = compare (node_value p) (node_value p')+ | otherwise = search (max s alpha) (max s b) ps+ where s = - jamboree valf (-beta) (-alpha) (depth-1) p
src/Board.hs view
@@ -1,26 +1,26 @@-{-# LANGUAGE BangPatterns #-}--- | Board State +{-# LANGUAGE BangPatterns, RecordWildCards #-}+-- | Board State module Board ( -- * Types Board (..) , PieceMap , Color (..) , Kind (..)- , Piece+ , Piece (..) , Position (..) , Move (..) , Game (..) , initBoard , initGame- , color, kind, height -- attributes of pieces + , color, kind, height -- attributes of pieces , nthTurn, nthMove , invert , inactive , countPieces , endGame , winner- , swapBoard- , captureMoves + , swapPlayer+ , captureMoves , stackingMoves , nextMoves , countStacks@@ -34,20 +34,28 @@ , showMove , applyMove , applyMoveSkip- , applyMoveSkip' , positions , zoneOfControl ) where -import Data.List-import Data.Map (Map, (!))-import qualified Data.Map as Map-import System.Random-import Control.Monad (liftM,mplus)+import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map +import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Hashable +import qualified Data.Vector.Unboxed as Vec+import Data.Vector.Unboxed(Vector)++import Data.Array++import Control.Monad (liftM, mplus)+import System.Random+ -- | player colors-data Color = White | Black +data Color = White | Black deriving (Eq,Show,Enum,Read) -- | the inverse color@@ -55,22 +63,23 @@ invert White = Black invert Black = White --- | The three piece types +-- | The three piece types -- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts.-data Kind = Tzaar | Tzarra | Tott - deriving (Eq, Ord, Show, Read)+data Kind = Tzaar | Tzarra | Tott+ deriving (Eq, Ord, Enum, Show, Read) -- | A piece stack: color, kind and height (starting at 1).-type Piece = (Color, Kind, Int)+data Piece = Piece !Color !Kind !Int+ deriving (Eq, Show, Read) color :: Piece -> Color-color (c, _, _) = c+color (Piece c _ _) = c kind :: Piece -> Kind-kind (_, k, _)= k+kind (Piece _ k _)= k height :: Piece -> Int-height (_, _, h)= h+height (Piece _ _ h)= h -- | Algebraic board positions. Letters left to right, numbers bottom to top.@@ -85,40 +94,44 @@ | G1 | G2 | G3 | G4 | G5 | G6 | G7 | H1 | H2 | H3 | H4 | H5 | H6 | I1 | I2 | I3 | I4 | I5- deriving (Eq, Ord, Enum, Bounded, Show, Read)+ deriving (Ix, Eq, Ord, Enum, Bounded, Show, Read) +instance Hashable Position where+ hashWithSalt s p = hashWithSalt s (fromEnum p)++ -- | List of all positions (for enumeration) positions :: [Position] positions = [minBound .. maxBound] --- | A mapping from positions to pieces -type PieceMap = Map Position Piece+-- | A mapping from positions to pieces+type PieceMap = HashMap Position Piece --- | The board state+-- | A TZAAR game board -- | current turn, active player pieces, other player pieces-data Board - = Board { active :: !Color, -- player to move next +data Board+ = Board { active :: !Color, -- player to move next move :: !Int, -- total move count- moves :: [Move], -- all previous moves (in reverse order) pieces :: PieceMap, -- map positions to pieces- activeCounts :: [Int], -- active player counts- inactiveCounts :: [Int], -- inactive player counts- activeHeights :: [Int],- inactiveHeights :: [Int]+ activeCounts :: !(Vector Int), -- active player counts+ inactiveCounts :: !(Vector Int), -- inactive player counts+ activeHeights :: !(Vector Int),+ inactiveHeights :: !(Vector Int) } deriving (Eq, Show, Read) -- | initialize a board from a list of piece & positions initBoard :: [(Position,Piece)] -> Board-initBoard assocs - = let ps = Map.fromList assocs- in Board { active=White, move=0, moves=[], pieces=ps,- activeCounts=countStacks White ps,- inactiveCounts=countStacks Black ps,- activeHeights=sumHeights White ps,- inactiveHeights=sumHeights Black ps +initBoard assocs+ = let ps = HashMap.fromList assocs+ in Board { active=White, move=0, + pieces=ps,+ activeCounts=Vec.fromList (countStacks White ps),+ inactiveCounts=Vec.fromList (countStacks Black ps),+ activeHeights=Vec.fromList (sumHeights White ps),+ inactiveHeights=Vec.fromList (sumHeights Black ps) }- + inactive :: Board -> Color inactive = invert . active @@ -127,8 +140,8 @@ -- | A move is either a capture, a stacking or a pass -- "Skip" is a dummy move to alternate players in a turn data Move = Capture !Position !Position -- origin and destination positions- | Stack !Position !Position - | Pass + | Stack !Position !Position+ | Pass | Skip deriving (Eq, Show, Read) @@ -145,9 +158,9 @@ { human :: Color -- human plays white or black? , initial :: Board -- initial board , board :: Board -- current board- , trail :: [Move] -- previous moves + , trail :: [Move] -- previous moves , remain :: [Move] -- future moves- } deriving (Eq,Show) + } deriving (Eq,Show) -- | initialize a game state@@ -156,7 +169,7 @@ --- | Convert number of moves into number of turns +-- | Convert number of moves into number of turns nthTurn :: Int -> Int nthTurn 0 = 1 nthTurn m | m>0 = 2 + (m-1)`div`3@@ -169,80 +182,78 @@ -- | number of pieces in a board countPieces :: Board -> Int-countPieces board = Map.size (pieces board) +countPieces board = HashMap.size (pieces board) -- | swap active player--- this is used to analyse the board from the opponent's prespective-swapBoard :: Board -> Board-swapBoard b = b { active= invert (active b), - activeCounts = inactiveCounts b, - inactiveCounts = activeCounts b,- activeHeights= inactiveHeights b,- inactiveHeights = activeHeights b- }+swapPlayer :: Board -> Board+swapPlayer b = b { active = invert (active b),+ activeCounts = inactiveCounts b,+ inactiveCounts = activeCounts b,+ activeHeights = inactiveHeights b,+ inactiveHeights = activeHeights b+ } --- | next moves for the active player+-- | all available moves for the active player nextMoves :: Board -> [Move]-nextMoves b - | tzaars==0 || tzarras==0 || totts==0 = []+nextMoves b+ | Vec.any (==0) (activeCounts b) = [] | m == 0 = captureMoves b- | otherwise + | otherwise = case (m-1)`mod`3 of 0 -> captureMoves b -- first move 1 -> [Skip] -- dummy opponent move within a turn 2 -> stackingMoves b ++ captureMoves b ++ [Pass] -- second moves _ -> error "nextMoves: invalid board"- where -- lostPieces = any (==0) (countStacks (active b) (pieces b)) - tzaars:tzarras:totts:_ = activeCounts b- m = move b+ where m = move b -- | next capture moves for the active player captureMoves :: Board -> [Move]-captureMoves board = Map.foldrWithKey forPiece [] (pieces board)+captureMoves Board{..} = HashMap.foldrWithKey forPiece [] pieces where- c = active board forPiece :: Position -> Piece -> [Move] -> [Move]- forPiece !p (!c', _, !i) moves - | c==c' = foldl' downLine moves (sixLines p)+ forPiece !p (Piece c _ i) moves+ | c==active = foldl' downLine moves (sixLines p) | otherwise = moves where downLine :: [Move] -> [Position] -> [Move] downLine moves [] = moves- downLine moves (q:ps) - = case Map.lookup q (pieces board) of- Nothing -> downLine moves ps - Just (c', _, j) | c/=c' && i>=j -> (Capture p q):moves+ downLine moves (q:rest)+ = case {-# SCC "piece-lookup" #-} HashMap.lookup q pieces of+ Nothing -> downLine moves rest+ Just (Piece c _ j) | c/=active && i>=j -> (Capture p q):moves _ -> moves -- | next stacking moves for the active player stackingMoves :: Board -> [Move]-stackingMoves board = foldl' forPiece [] (Map.assocs (pieces board))- where +stackingMoves board = HashMap.foldlWithKey' forPiece [] (pieces board)+ where c = active board- tzaars:tzarras:totts:_ = activeCounts board- forPiece :: [Move] -> (Position,Piece) -> [Move]- forPiece moves (p,(c',_,_)) + tzaars = activeCounts board Vec.! fromEnum Tzaar+ tzarras= activeCounts board Vec.! fromEnum Tzarra+ totts = activeCounts board Vec.! fromEnum Tott+ forPiece :: [Move] -> Position -> Piece -> [Move]+ forPiece moves p (Piece c' _ _) | c==c' = foldl' downLine moves (sixLines p) | otherwise = moves where downLine :: [Move] -> [Position] -> [Move] downLine moves [] = moves- downLine moves (q:ps) - = case Map.lookup q (pieces board) of+ downLine moves (q:ps)+ = case {-# SCC "piece-lookup" #-} HashMap.lookup q (pieces board) of Nothing -> downLine moves ps- Just (c', _, _) | c/=c' -> moves- Just (_, Tzaar, _) | tzaars==1 -> moves- Just (_, Tzarra, _) | tzarras==1 -> moves- Just (_, Tott, _) | totts==1 -> moves- Just (_, _, _) -> (Stack p q) : moves+ Just (Piece c' _ _) | c/=c' -> moves+ Just (Piece _ Tzaar _) | tzaars==1 -> moves+ Just (Piece _ Tzarra _) | tzarras==1 -> moves+ Just (Piece _ Tott _) | totts==1 -> moves+ Just _ -> (Stack p q) : moves @@ -250,62 +261,60 @@ -- | count the number of stacks of each type in a half-board countStacks :: Color -> PieceMap -> [Int] countStacks c pieces- = count 0 0 0 (Map.elems pieces)+ = count 0 0 0 (HashMap.elems pieces) where count :: Int -> Int -> Int -> [Piece] -> [Int]- count !x !y !z ((c',Tzaar,_) : ps) | c==c' = count (1+x) y z ps- count !x !y !z ((c',Tzarra,_) : ps) | c==c' = count x (1+y) z ps- count !x !y !z ((c',Tott,_) : ps) | c==c' = count x y (1+z) ps- count !x !y !z (_ : ps) = count x y z ps + count !x !y !z ((Piece c' Tzaar _) : ps) | c==c' = count (1+x) y z ps+ count !x !y !z ((Piece c' Tzarra _) : ps) | c==c' = count x (1+y) z ps+ count !x !y !z ((Piece c' Tott _) : ps) | c==c' = count x y (1+z) ps+ count !x !y !z (_ : ps) = count x y z ps count !x !y !z [] = [x,y,z] -- | sum of heights of stacks for each kind sumHeights :: Color -> PieceMap -> [Int]-sumHeights c pieces = sum 0 0 0 (Map.elems pieces)+sumHeights c pieces = sum 0 0 0 (HashMap.elems pieces) where sum :: Int -> Int -> Int -> [Piece] -> [Int]- sum !x !y !z ((c',Tzaar,!h):ps) | c==c' = sum (x+h) y z ps- sum !x !y !z ((c',Tzarra,!h):ps) | c==c' = sum x (y+h) z ps- sum !x !y !z ((c',Tott,!h):ps) | c==c' = sum x y (z+h) ps+ sum !x !y !z ((Piece c' Tzaar !h):ps) | c==c' = sum (x+h) y z ps+ sum !x !y !z ((Piece c' Tzarra !h):ps) | c==c' = sum x (y+h) z ps+ sum !x !y !z ((Piece c' Tott !h):ps) | c==c' = sum x y (z+h) ps sum !x !y !z (_ : ps) = sum x y z ps sum !x !y !z [] = [x,y,z] -- | maximum height for each kind-maxHeights :: Color -> PieceMap -> [Int] -maxHeights c pieces = maxh 0 0 0 (Map.elems pieces)+maxHeights :: Color -> PieceMap -> [Int]+maxHeights c pieces = maxh 0 0 0 (HashMap.elems pieces) where maxh :: Int -> Int -> Int -> [Piece] -> [Int]- maxh !x !y !z ((c',Tzaar,!h):ps) | c==c' && h>x = maxh h y z ps- maxh !x !y !z ((c',Tzarra,!h):ps) | c==c' && h>y= maxh x h z ps - maxh !x !y !z ((c',Tott,!h):ps) | c==c' && h>z = maxh x y h ps+ maxh !x !y !z ((Piece c' Tzaar !h):ps) | c==c' && h>x = maxh h y z ps+ maxh !x !y !z ((Piece c' Tzarra !h):ps) | c==c' && h>y= maxh x h z ps+ maxh !x !y !z ((Piece c' Tott !h):ps) | c==c' && h>z = maxh x y h ps maxh !x !y !z (_ : ps) = maxh x y z ps maxh !x !y !z [] = [x,y,z] --- | The next board state after a move. +-- | The next board state after a move. -- | Assumes the move is valid. applyMove :: Move -> Board -> Board-applyMove m@(Capture x y) b - = b {active=invert (active b), - move=1+move b, - moves = m:moves b,- pieces= pieces', +applyMove m@(Capture x y) b+ = b {active=invert (active b),+ move=1+move b,+ pieces= pieces', activeCounts = counts', -- swap counts inactiveCounts= activeCounts b, activeHeights = heights', -- swap heights inactiveHeights = activeHeights b } where- pX = pieces b!x - (_, kindY, sizeY) = pieces b!y- pieces' = Map.insert y pX (Map.delete x (pieces b))+ pX = pieces b HashMap.! x+ (Piece _ kindY sizeY) = pieces b HashMap.! y+ pieces' = {-# SCC "piece-insert" #-} HashMap.insert y pX (HashMap.delete x (pieces b)) counts' = increment kindY (-1) (inactiveCounts b) heights'= increment kindY (-sizeY) (inactiveHeights b) -applyMove m@(Stack x y) b - = b {active=invert (active b), - move=1+move b, - moves= m:moves b,+applyMove m@(Stack x y) b+ = b {active=invert (active b),+ move=1+move b, pieces=pieces', activeCounts = inactiveCounts b, inactiveCounts = counts',@@ -313,19 +322,18 @@ inactiveHeights= heights' } where- (colorX, kindX, sizeX) = pieces b!x- (_, kindY, sizeY) = pieces b!y- pieces' = Map.insert y (colorX,kindX,sizeX+sizeY) (Map.delete x (pieces b))+ (Piece colorX kindX sizeX) = pieces b HashMap.! x+ (Piece _ kindY sizeY) = pieces b HashMap.! y+ pieces' = {-# SCC "piece-ins-del" #-} HashMap.insert y (Piece colorX kindX (sizeX+sizeY)) (HashMap.delete x (pieces b)) counts' = increment kindY (-1) (activeCounts b) heights' | kindX==kindY = activeHeights b- | otherwise = increment kindY (-sizeY) $ + | otherwise = increment kindY (-sizeY) $ increment kindX sizeY (activeHeights b)- - ++ -- Pass & Skip have the same effect-applyMove m b = b {active= invert (active b), - move=1+move b, - moves= m:moves b,+applyMove m b = b {active= invert (active b),+ move=1+move b, activeCounts= inactiveCounts b, inactiveCounts= activeCounts b, activeHeights= inactiveHeights b,@@ -333,35 +341,23 @@ } -- | modify a counter-increment :: Kind -> Int -> [Int] -> [Int]-increment Tzaar i (tzaars:tzarras:totts:_) = (tzaars+i) : tzarras : totts : []-increment Tzarra i (tzaars:tzarras:totts:_) = tzaars : (tzarras+i) : totts : []-increment Tott i (tzaars:tzarras:totts:_) = tzaars : tzarras : (totts+i) : []+increment :: Kind -> Int -> Vector Int -> Vector Int+increment !k !n v = v Vec.// [(i, n + v Vec.! i)]+ where !i = fromEnum k -- | apply one move and subsequent skip move-applyMoveSkip :: Move -> Board -> Board -applyMoveSkip m b +applyMoveSkip :: Move -> Board -> Board+applyMoveSkip m b = case nextMoves b' of- (Skip:_) -> applyMove Skip b' -- compulsory move- _ -> b'+ [Skip] -> applyMove Skip b' -- compulsory move+ _ -> b' where b' = applyMove m b --- | apply one move checking for validity-applyMoveSkip' :: Board -> Move -> Maybe Board-applyMoveSkip' b m- | m`elem`ms = - case nextMoves b' of- (Skip:_) -> Just (applyMove Skip b')- _ -> Just b'- | otherwise = Nothing- where ms = nextMoves b- b' = applyMove m b - endGame :: Board -> Bool-endGame = null . nextMoves +endGame = null . nextMoves winner :: Board -> Color winner = invert . active@@ -389,7 +385,7 @@ , [B6, C6, D6, E5, F5, G4, H3, I2] , [C7, D7, E6, F6, G5, H4, I3] , [D8, E7, F7, G6, H5, I4]- , [E8, F8, G7, H6, I5] + , [E8, F8, G7, H6, I5] , [E1, F1, G1, H1, I1] , [D1, E2, F2, G2, H2, I2] , [C1, D2, E3, F3, G3, H3, I3]@@ -402,39 +398,36 @@ , [A5, B6, C7, D8, E8] ] --- | The three lines that cross at a single board position.-threeLines :: Position -> [[Position]]-threeLines p = [ line | line <- connectedPositions, elem p line ] - -- | The six lines traveling radially out from a single board position.--- | optimization: this map should be memoied lazily -sixLines_memo :: Map Position [[Position]] -- Map Position [[Position]]-sixLines_memo = Map.fromList [(p, radials p) | p<-positions]+sixLines :: Position -> [[Position]]+sixLines p = sixLinesArray ! p++-- | global memoied array +sixLinesArray :: Array Position [[Position]]+sixLinesArray = array (minBound,maxBound) [(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 -sixLines :: Position -> [[Position]]-sixLines p = sixLines_memo!p---+-- | The three lines that cross at a single board position.+threeLines :: Position -> [[Position]]+threeLines p = [ line | line <- connectedPositions, p `elem` line ] -- | An empty board emptyBoard :: Board-emptyBoard = initBoard [] +emptyBoard = initBoard [] -- | The default (non-randomized, non-tournament) starting position. startingBoard :: Board-startingBoard = initBoard (whites ++ blacks) +startingBoard = initBoard (whites ++ blacks) where- whites = [(p, (White,Tzaar,1)) | p<-wTzaars] ++ - [(p, (White,Tzarra,1)) | p<-wTzarras] ++ - [(p, (White,Tott,1)) | p<-wTotts]- blacks = [(p, (Black,Tzaar,1)) | p<-bTzaars] ++ - [(p, (Black,Tzarra,1)) | p<-bTzarras] ++ - [(p, (Black,Tott,1)) | p<-bTotts]+ whites = [(p, (Piece White Tzaar 1)) | p<-wTzaars] +++ [(p, (Piece White Tzarra 1)) | p<-wTzarras] +++ [(p, (Piece White Tott 1)) | p<-wTotts]+ blacks = [(p, (Piece Black Tzaar 1)) | p<-bTzaars] +++ [(p, (Piece Black Tzarra 1)) | p<-bTzarras] +++ [(p, (Piece Black Tott 1)) | p<-bTotts] wTzaars = [D3, E3, G4, G5, C5, D6] wTzarras = [C2, D2, E2, H3, H4, H5, B5, C6, D7] wTotts = [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]@@ -446,13 +439,13 @@ -- | A randomized starting position randomBoard :: StdGen -> (Board, StdGen) randomBoard rnd = (b, rnd')- where b = initBoard (whites++blacks) - ws = replicate 6 (White,Tzaar,1) ++- replicate 9 (White,Tzarra,1) ++- replicate 15 (White,Tott,1)- bs = replicate 6 (Black,Tzaar,1) ++- replicate 9 (Black,Tzarra,1) ++- replicate 15 (Black,Tott,1)+ where b = initBoard (whites++blacks)+ ws = replicate 6 (Piece White Tzaar 1) +++ replicate 9 (Piece White Tzarra 1) +++ replicate 15 (Piece White Tott 1)+ bs = replicate 6 (Piece Black Tzaar 1) +++ replicate 9 (Piece Black Tzarra 1) +++ replicate 15 (Piece Black Tott 1) (positions',rnd') = shuffle rnd positions whites = zip (take 30 positions') ws blacks = zip (drop 30 positions') bs@@ -469,7 +462,7 @@ shuffle g xs = shuffle' g xs (length xs) where shuffle' :: RandomGen g => g -> [a] -> Int -> ([a], g)- shuffle' g xs n + shuffle' g xs n | n>0 = let (k, g') = randomR (0,n-1) g (xs',x:xs'') = splitAt k xs (ys,g'') = shuffle' g' (xs' ++ xs'') (n-1)@@ -482,37 +475,36 @@ -- Estimate the zone of control of a player -- i.e., the opponents' pieces that can be captured in two moves zoneOfControl :: Color -> PieceMap -> PieceMap-zoneOfControl c pieces = Map.filterWithKey forPiece1 pieces+zoneOfControl c pieces = HashMap.filterWithKey forPiece1 pieces where -- player's pieces that make at least one capture- movable = Map.filterWithKey forPiece2 pieces+ movable = HashMap.filterWithKey forPiece2 pieces forPiece1, forPiece2 :: Position -> Piece -> Bool- forPiece1 p (c', _, i) = c'/=c && or (map (downLine0 i) $ sixLines p)- forPiece2 p (c',_, h) = c'==c && or (map (downLine2 h) $ sixLines p)+ forPiece1 p (Piece c' _ i) = c'/=c && any (downLine0 i) (sixLines p)+ forPiece2 p (Piece c' _ h) = c'==c && any (downLine2 h) (sixLines p) downLine0, downLine1, downLine2 :: Int -> [Position] -> Bool - downLine0 i [] = False- downLine0 i (p:ps) - = case Map.lookup p pieces of+ downLine0 !i [] = False+ downLine0 !i (p:ps)+ = case HashMap.lookup p pieces of Nothing -> downLine0 i ps- Just (c', _, h) | c'==c -> - h>=i || (p`Map.member`movable && downLine1 i ps)- Just (c', _, j) | c'/=c -> - or $ map (downLine1 (max i j)) $ sixLines p+ Just (Piece c' _ h) -> if c==c' then+ h>=i || (p`HashMap.member`movable && downLine1 i ps)+ else+ let !h' = max i h+ in any (downLine1 h') (sixLines p) - downLine1 i [] = False- downLine1 i (p:ps) - = case Map.lookup p pieces of++ downLine1 !i [] = False+ downLine1 !i (p:ps)+ = case HashMap.lookup p pieces of Nothing -> downLine1 i ps- Just (c', _, h) -> c'==c && h>=i+ Just (Piece c' _ h) -> c'==c && h>=i - downLine2 h [] = False- downLine2 h (p:ps) - = case Map.lookup p pieces of+ downLine2 !h [] = False+ downLine2 !h (p:ps)+ = case HashMap.lookup p pieces of Nothing -> downLine2 h ps- Just (c', _, i) -> c'/=c && h>=i---+ Just (Piece c' _ i) -> c'/=c && h>=i
src/GUI.hs view
@@ -10,11 +10,13 @@ import Graphics.UI.Gtk.Glade import Graphics.Rendering.Cairo hiding (version) import Data.Function (on)-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map+import qualified Data.HashMap.Strict as HashMap import Data.Map (Map, (!)) import Data.List (minimumBy, sortBy) import Control.Concurrent import Control.Monad (when, filterM, liftM, mplus, msum)+import Control.Monad.State (runState) import System.IO import System.FilePath import System.Random hiding (next)@@ -24,14 +26,14 @@ --import AI.Eval -- import History (History) -- import qualified History as History-import Serialize -- convert to/from XML +import Serialize -- convert to/from XML import Text.XML.Light -- | Selection state data State = Wait0 -- wait for human (1st position) | Wait1 Position -- wait for human (2nd position)- | WaitAI (MVar Move) -- wait for AI + | WaitAI (MVar Move) -- wait for AI | Finish -- game ended @@ -45,11 +47,11 @@ initGameState gui b White = return (initGame b White, Wait0) initGameState gui b Black = do ai <- getAI gui mvar <- newEmptyMVar- forkOS $ runAI ai b mvar + forkOS $ runAI ai b mvar return (initGame b Black, WaitAI mvar) - + -- | record to hold references to the GUI widgets data GUI = GUI { mainwin :: Window,@@ -87,9 +89,9 @@ loadGlade :: FilePath -> IO GUI loadGlade path = do out <- xmlNew path- case out of + case out of Nothing -> error ("unable to open glade file " ++ show path)- Just xml -> + Just xml -> do mw <- xmlGetWidget xml castToWindow "mainwindow" abd <- xmlGetWidget xml castToAboutDialog "aboutdialog" std <- xmlGetWidget xml castToDialog "startdialog"@@ -111,7 +113,7 @@ playb <- xmlGetWidget xml castToRadioButton "playblack" mab<- xmlGetWidget xml castToMenuItem "menu_item_about" -- fill in dynamic parts- aboutDialogSetVersion abd (showVersion version) + aboutDialogSetVersion abd (showVersion version) bd <- drawingAreaNew containerAdd fr bd m<- xmlGetWidget xml castToMenu "menu_ai"@@ -124,18 +126,18 @@ menuAttach m w 0 1 i (i+1) return w | (i,ai)<-zip [1..] (tail aiLevels)]- -- select default AI: this is hardcoded to be the *second* entry + -- select default AI: this is hardcoded to be the *second* entry checkMenuItemSetActive r1 True tooltipsEnable tips -- open/save file dialogs- ff <- fileFilterNew + ff <- fileFilterNew fileFilterSetName ff "Tzaar saved games (*.tza)" fileFilterAddPattern ff "*.tza"- opf <- fileChooserDialogNew (Just "Open saved game") Nothing FileChooserActionOpen - [("Cancel",ResponseCancel),("Open",ResponseOk)] + opf <- fileChooserDialogNew (Just "Open saved game") Nothing FileChooserActionOpen+ [("Cancel",ResponseCancel),("Open",ResponseOk)] fileChooserAddFilter opf ff svf <- fileChooserDialogNew (Just "Save game") Nothing FileChooserActionSave- [("Cancel",ResponseCancel),("Save",ResponseOk)] + [("Cancel",ResponseCancel),("Save",ResponseOk)] fileChooserAddFilter svf ff cid <- statusbarGetContextId sb "status" widgetShowAll mw@@ -144,47 +146,46 @@ -- | main GUI entry point gui :: FilePath -> IO ()-gui path = +gui path = do initGUI gui <- loadGlade path- b <- randomBoardIO + b <- randomBoardIO g <- initGameState gui b White -- human plays white by default gamev <- newMVar g- connect_events gui gamev - -- timer event for updating the gui + connect_events gui gamev+ -- timer event for updating the gui timeoutAdd (updateGUI gui gamev >> return True) 100 -- start GTK event loop mainGUI -- | connect event handlers for GUI elements-connect_events gui gamev - = do onExpose (canvas gui) $ \x -> +connect_events gui gamev+ = do onExpose (canvas gui) $ \x -> do drawCanvas gui gamev return (eventSent x) onButtonPress (canvas gui) $ \x -> do mp<-getPosition (canvas gui) (eventX x) (eventY x)- case mp of + case mp of Nothing -> return (eventSent x) Just p -> do clickBoard gui gamev p return (eventSent x) onDestroy (mainwin gui) mainQuit- onActivateLeaf (menu_item_about gui) $ + onActivateLeaf (menu_item_about gui) $ do { dialogRun (aboutdialog gui) ; widgetHide (aboutdialog gui) } onActivateLeaf (menu_item_quit gui) mainQuit onActivateLeaf (menu_item_new gui) (newGame gui gamev)- onActivateLeaf (menu_item_open gui) $ + onActivateLeaf (menu_item_open gui) $ do { answer<-fileDialogRun (open_file_chooser gui) ; case answer of- Just path -> do ai <- getAI gui - openGame ai gamev path+ Just path -> do openGame gamev path redrawCanvas (canvas gui) Nothing -> return () }- onActivateLeaf (menu_item_save gui) $ + onActivateLeaf (menu_item_save gui) $ do { answer<-fileDialogRun (save_file_chooser gui) ; case answer of Just path -> saveGame gamev (replaceExtension path ".tza")@@ -202,7 +203,7 @@ -- | start a new game newGame :: GUI -> MVar (Game,State) -> IO ()-newGame gui gamev +newGame gui gamev = do answer <- dialogRun (startdialog gui) widgetHide (startdialog gui) case answer of@@ -210,7 +211,7 @@ _ -> return () where startgame = do r <- toggleButtonGetActive (fixed_position gui)- b <- if r then return startingBoard else randomBoardIO + b <- if r then return startingBoard else randomBoardIO r <- toggleButtonGetActive (play_white gui) let c = if r then White else Black modifyMVar_ gamev (\_ -> initGameState gui b c)@@ -218,38 +219,28 @@ -- | open a saved game-openGame :: AI -> MVar (Game,State) -> FilePath -> IO ()-openGame ai gamev filepath+openGame :: MVar (Game,State) -> FilePath -> IO ()+openGame gamev filepath = withFile filepath ReadMode $ \handle ->- do txt <- hGetContents handle + do txt <- hGetContents handle case readXML txt of- Nothing -> - putStrLn ("ERROR: couldn't parse game file " ++ show filepath)- Just g -> - let b = board g- in modifyMVar_ gamev $ - \_ -> if endGame b then- return (g,Finish)- else if active b == human g then- return (g,Wait0)- else do { mvar <- newEmptyMVar- ; forkOS $ runAI ai b mvar- ; return (g,WaitAI mvar)- }+ Nothing -> putStrLn ("ERROR: couldn't parse game file " ++ show filepath)+ Just g -> let s = if endGame (board g) then Finish else Wait0+ in modifyMVar_ gamev $ \_ -> return (g,s) -- | write a game file saveGame :: MVar (Game,State) -> FilePath -> IO ()-saveGame gamev filepath +saveGame gamev filepath = do (g,_) <- readMVar gamev- withFile filepath WriteMode $ + withFile filepath WriteMode $ \handle -> hPutStr handle (showXML g) fileDialogRun :: FileChooserDialog -> IO (Maybe FilePath)-fileDialogRun w = do { r<-dialogRun w +fileDialogRun w = do { r<-dialogRun w ; widgetHide w- ; case r of + ; case r of ResponseOk -> fileChooserGetFilename w _ -> return Nothing }@@ -257,29 +248,29 @@ -- | get the selected AI player getAI :: GUI -> IO AI-getAI gui +getAI gui = do rs<-filterM (checkMenuItemGetActive . fst) (zip (menu_item_ai_levels gui) [0..]) let i = snd (head rs) return (aiLevels !! i)- + -- | periodically update the GUI elements when waiting for AI updateGUI :: GUI -> MVar (Game,State) -> IO ()-updateGUI gui gamev - = modifyMVar_ gamev $ \(g,s) -> +updateGUI gui gamev+ = modifyMVar_ gamev $ \(g,s) -> let m = nthMove (move (board g)) -- 1st or 2nd move of turn? in do { widgetSetSensitive (menu_item_undo gui) $ not (waitingAI s) && not (null (trail g)) ; widgetSetSensitive (menu_item_redo gui) $ not (waitingAI s) && not (null (remain g))- ; widgetSetSensitive (menu_item_pass gui) $ + ; widgetSetSensitive (menu_item_pass gui) $ not (waitingAI s) && m==2 ; updateStatus gui (statusText g s)- ; case s of - WaitAI mvar -> + ; case s of+ WaitAI mvar -> do { reply <- tryTakeMVar mvar- ; case reply of + ; case reply of Nothing -> do { progressBarPulse (progressbar gui) ; return (g,s) } Just m -> do { redrawCanvas (canvas gui)@@ -294,16 +285,16 @@ statusText :: Game -> State -> String statusText g s- = let b = board g - n = move b - msg = "Turn " ++ show (nthTurn n) ++ ", move " ++ show (nthMove n) ++ ": " - in case s of + = let b = board g+ n = move b+ msg = "Turn " ++ show (nthTurn n) ++ ", move " ++ show (nthMove n) ++ ": "+ in case s of Finish -> show (winner b) ++ " wins." WaitAI _ -> msg ++ show (active b) ++ " thinking..."- _ -> msg ++ show (active b) ++ " to play." - + _ -> msg ++ show (active b) ++ " to play." + -- | replace the status message updateStatus :: GUI -> String -> IO () updateStatus gui txt@@ -314,15 +305,15 @@ -- | pass the 2nd move of a turn passMove :: GUI -> MVar (Game,State) -> IO ()-passMove gui gamev - = modifyMVar_ gamev $ - \(g,s) -> +passMove gui gamev+ = modifyMVar_ gamev $+ \(g,s) -> if human g == active (board g) then -- human to play? let moves = nextMoves (board g) in case s of- Wait0 | Pass`elem`moves -> + Wait0 | Pass`elem`moves -> do ai <- getAI gui- redrawCanvas (canvas gui) + redrawCanvas (canvas gui) makeMove ai Pass g _ -> return (g,s) else return (g,s)@@ -331,12 +322,12 @@ -- | undo/redo move history navigation undoMove :: GUI -> MVar (Game,State) -> IO ()-undoMove gui gamev +undoMove gui gamev = modifyMVar_ gamev $ \(g,s) ->- let ms = trail g - in case ms of + let ms = trail g+ in case ms of [] -> return (g,s)- (m:ms') -> + (m:ms') -> let b'= foldr applyMoveSkip (initial g) ms' s'= if endGame b' then Finish else Wait0 in do redrawCanvas (canvas gui)@@ -344,12 +335,12 @@ redoMove :: GUI -> MVar (Game,State) -> IO ()-redoMove gui gamev +redoMove gui gamev = modifyMVar_ gamev $ \(g,s) ->- let ms = remain g - in case ms of + let ms = remain g+ in case ms of [] -> return (g,s)- (m:ms') -> + (m:ms') -> let b' = applyMoveSkip m (board g) s' = if endGame b' then Finish else Wait0 in do redrawCanvas (canvas gui)@@ -360,24 +351,24 @@ clickBoard :: GUI -> MVar (Game,State) -> Position -> IO () clickBoard gui gamev p = do { ai <- getAI gui- ; modifyMVar_ gamev $ \(g,s) -> + ; modifyMVar_ gamev $ \(g,s) -> if active (board g) == human g -- user's turn to play?- then - let moves = nextMoves (board g) + then+ let moves = nextMoves (board g) in case s of Wait0 | p`prefix`moves -> return (g, Wait1 p) Wait1 p' | p'==p -> return (g, Wait0)- Wait1 p' | (Capture p' p)`elem`moves -> + Wait1 p' | (Capture p' p)`elem`moves -> makeMove ai (Capture p' p) g- Wait1 p' | (Stack p' p)`elem`moves -> + Wait1 p' | (Stack p' p)`elem`moves -> makeMove ai (Stack p' p) g _ -> return (g,s) else return (g,s) ; redrawCanvas (canvas gui) }- + -- | check if we can start a move from a position prefix :: Position -> [Move] -> Bool prefix p moves@@ -393,24 +384,24 @@ makeMove ai m g | endGame b' = return (g',Finish) | active b' == human g = return (g',Wait0)- | otherwise = + | otherwise = do { mvar <- newEmptyMVar- ; forkOS $ runAI ai b' mvar + ; forkOS $ runAI ai b' mvar ; return (g',WaitAI mvar) } where b' = applyMoveSkip m (board g) g' = g {board=b', trail=m:trail g, remain=[]}- - ++ -- | separate thread for the AI opponent runAI :: AI -> Board -> MVar Move -> IO () runAI ai b mvar = do { threadDelay (200*1000) -- short delay to allow GUI redraw ; rnd <- getStdGen- ; let (score, m, rnd') = playing ai b rnd+ ; let ((m, score), rnd') = runState (strategy ai b) rnd ; setStdGen rnd'- -- ; putStrLn ("AI move: "++show m ++ " score: " ++ show score)+ ; putStrLn ("AI move: "++show m ++ "\t" ++ show score) ; m `seq` putMVar mvar m } @@ -435,8 +426,8 @@ drawin <- widgetGetDrawWindow (canvas gui) (g,s) <- readMVar gamev renderWithDrawable drawin $- renderWithSimilarSurface ContentColor w h $ - \tmp -> + renderWithSimilarSurface ContentColor w h $+ \tmp -> do renderWith tmp (setTransform w h >> renderBoard b1 b2 b3 g s) setSourceSurface tmp 0 0 paint@@ -445,7 +436,7 @@ -- | render the board and pieces renderBoard :: Bool -> Bool -> Bool -> Game -> State -> Render () renderBoard showHeights showMoves showStacks g s- = do boardBg >> paint -- paint the background + = do boardBg >> paint -- paint the background -- paint the playing area light gray gray 0.9 >> polyLine [A1, A5, E8, I5, I1, E1] >> closePath >> fill -- repaint the center with background color@@ -456,9 +447,9 @@ case s of Wait0 -> do renderPieces showHeights showStacks b when showMoves $ mapM_ renderMove previous- Wait1 p -> do highlight p + Wait1 p -> do highlight p renderPieces showHeights showStacks b- when showMoves $ + when showMoves $ do mapM_ renderMove (targets p) mapM_ renderMove previous WaitAI _ -> do renderPieces showHeights showStacks b@@ -469,21 +460,21 @@ moves = nextMoves b -- next available moves previous = take 2 (trail g) -- opponent's previous moves -- move targets from a position- targets p = [m | m@(Capture p1 p2)<-moves, p1==p] ++ + targets p = [m | m@(Capture p1 p2)<-moves, p1==p] ++ [m | m@(Stack p1 p2)<-moves, p1==p] renderMove :: Move -> Render ()-renderMove (Capture p1 p2) +renderMove (Capture p1 p2) = do { setSourceRGBA 1 0 0 0.7; arrowFromTo p1 p2 }-renderMove (Stack p1 p2) +renderMove (Stack p1 p2) = do { setSourceRGBA 0 0 1 0.7; arrowFromTo p1 p2 } renderMove Pass = return () renderMove Skip = return () arrowFromTo :: Position -> Position -> Render () arrowFromTo p1 p2 = do setLineWidth 10- moveTo xstart ystart + moveTo xstart ystart lineTo x0 y0 stroke setLineWidth 1@@ -509,13 +500,13 @@ renderGrid :: Render () renderGrid = do gray 0 setLineWidth 1- sequence_ [lineFromTo p1 p2 | (p1,p2)<-lines] + sequence_ [lineFromTo p1 p2 | (p1,p2)<-lines] setFontSize 22 sequence_ [do uncurry moveTo $ tr (-10,60) $ screenCoordinate p- showText (show p) + showText (show p) | p<-[A1,B1,C1,D1,E1,F1,G1,H1,I1]] sequence_ [do uncurry moveTo $ tr (-10,-50) $ screenCoordinate p- showText (show p) + showText (show p) | p<-[A5, B6,C7,D8,E8,F8,G7,H6,I5]] where tr (dx,dy) (x,y) = (x+dx,y+dy) lineFromTo p1 p2 = do uncurry moveTo $ screenCoordinate p1@@ -523,7 +514,7 @@ stroke lines = [(A1,A5), (B1,B6), (C1,C7), (D1,D8), (E1,E4), (E5,E8), (F1,F8), (G1,G7), (H1,H6), (I1,I5),- (A1,E1), (A2,F1),(A3,G1), (A4,H1), + (A1,E1), (A2,F1),(A3,G1), (A4,H1), (A5, D5), (F4,I1), (B6,I2), (C7,I3), (D8,I4), (E8,I5), (E1,I1), (D1,I2), (C1,I3), (B1,I4), (A1,D4), (F5,I5), (A5,E8), (A4,F8), (A3,G7), (A2,H6)]@@ -532,23 +523,23 @@ -- setup coordinate transform for the board setTransform :: Int -> Int -> Render ()-setTransform w h +setTransform w h = do translate (fromIntegral w/2) (fromIntegral h/2)- scale (fromIntegral side/1000) (fromIntegral side/1000) + scale (fromIntegral side/1000) (fromIntegral side/1000) where side = min w h -- constraint to square aspect ratio - + -- board background (pale yellow) boardBg :: Render ()-boardBg = setSourceRGB 1 0.95 0.6 +boardBg = setSourceRGB 1 0.95 0.6 -- shades of gray from 0 (black) to 1 (white) gray :: Double -> Render () gray x = setSourceRGB x x x- + -- draw a polygonal line polyLine :: [Position] -> Render () polyLine (p:ps) = do uncurry moveTo $ screenCoordinate p@@ -567,13 +558,13 @@ -- render all pieces in the board renderPieces :: Bool -> Bool -> Board -> Render ()-renderPieces showheights showstacks board +renderPieces showheights showstacks board = do setLineWidth 2 -- board pieces- sequence_ [ renderStack showheights showstacks x y piece | + sequence_ [ renderStack showheights showstacks x y piece | (pos,piece) <- assocs, let (x,y)= screenCoordinate pos] -- sort pieces by reverse position to draw from back to front- where assocs = sortBy cmp $ Map.assocs (pieces board)+ where assocs = sortBy cmp $ HashMap.toList (pieces board) cmp (x,_) (y,_) = compare y x -- captures = capturedPieces board -- whiteCaptures = [(White,k,n) | (White,k,n)<-captures]@@ -586,20 +577,20 @@ -- | render a stack of pieces renderStack :: Bool -> Bool -> Double -> Double -> Piece -> Render ()-renderStack showheight showstacks xc yc (c,t,size)- = do stack size' yc +renderStack showheight showstacks xc yc (Piece c t size)+ = do stack size' yc when (showheight && size>1) $ -- show the height? do selectFontFace "sans-serif" FontSlantNormal FontWeightBold setFontSize 50- setSourceRGB 1 1 1 + setSourceRGB 1 1 1 showCenteredText (xc+2) (yt+2) label- setSourceRGB 1 0 0 + setSourceRGB 1 0 0 showCenteredText xc yt label where label = show size size' = if showstacks then size else 1 -- (xc,yc)= screenCoordinate p yt = yc - 10*fromIntegral (size'-1)- stack n y + stack n y | n>1 = do renderPiece xc y c Tott stack (n-1) (y-10) | otherwise = renderPiece xc y c t@@ -607,28 +598,28 @@ -- | render a single piece renderPiece :: Double -> Double -> Board.Color -> Kind -> Render ()-renderPiece x y c k - = do { chipColor; disc 1 x y; +renderPiece x y c k+ = do { chipColor; disc 1 x y; lineColor; ring 1 x y;- case k of + case k of Tzaar -> do {crownColor; disc 0.8 x y; chipColor; disc 0.6 x y; crownColor; disc 0.4 x y} Tzarra -> do { crownColor; disc 0.4 x y } Tott -> return ()- } + } where (chipColor, lineColor, crownColor) = renderColors c showCenteredText :: Double -> Double -> String -> Render ()-showCenteredText x y txt - = do exts <- textExtents txt +showCenteredText x y txt+ = do exts <- textExtents txt let dx = textExtentsWidth exts/2 let dy = textExtentsHeight exts/2 moveTo (x-dx) (y+dy) showText txt- + disc :: Double -> Double -> Double -> Render () disc r x y = arc x y (r*33) 0 (2*pi) >> fill @@ -638,11 +629,11 @@ -- (chip color, line color, crown color) renderColors :: Board.Color -> (Render (), Render (), Render ())-renderColors Black = (setSourceRGB 0 0 0, +renderColors Black = (setSourceRGB 0 0 0, setSourceRGB 1 1 1, setSourceRGB 0.75 0.75 0.75)-renderColors White = (setSourceRGB 1 1 1, - setSourceRGB 0 0 0, +renderColors White = (setSourceRGB 1 1 1,+ setSourceRGB 0 0 0, setSourceRGB 0.35 0.25 0) @@ -652,10 +643,10 @@ getPosition canvas x y = do (w,h)<-widgetGetSize canvas drawin<- widgetGetDrawWindow canvas- (xu, yu)<- renderWithDrawable drawin + (xu, yu)<- renderWithDrawable drawin (setTransform w h >> deviceToUser x y)- let (p, d) = minimumBy (compare `on` snd) - [(p, (xu - x')^2 + (yu - y')^2) + let (p, d) = minimumBy (compare `on` snd)+ [(p, (xu - x')^2 + (yu - y')^2) | (p, (x', y')) <- Map.assocs screenCoordinates ] return (if d<900 then Just p else Nothing) @@ -666,7 +657,7 @@ screenCoordinate p = screenCoordinates!p screenCoordinates :: Map Position (Double,Double)-screenCoordinates +screenCoordinates = Map.fromList $ [ (A1, p (-4) (-2)) , (A2, p (-4) (-1))@@ -736,4 +727,3 @@ x' = fromIntegral x * sin (pi / 3) y' | even x = fromIntegral y | otherwise = fromIntegral y - (fromIntegral (signum y) * 0.5)-
src/Main.hs view
@@ -1,12 +1,11 @@ -- Main module for Haskell TZAAR game implementation--- Pedro Vasconcelos, 2010-2013+-- Pedro Vasconcelos, 2010 module Main (main) where import Paths_hstzaar import Board import AI import GUI-import Serialize import Tournament import Tests import Data.List (intersperse)@@ -20,34 +19,34 @@ import qualified Data.Map as Map data Flag = Seed Int- | NumMatches Int + | NumMatches Int | DataDir FilePath | RunTests deriving Show options :: [OptDescr Flag]-options = [Option ['s'] ["seed"] (ReqArg (Seed . read) "SEED") +options = [Option ['s'] ["seed"] (ReqArg (Seed . read) "SEED") "random number seed",- Option ['n'] ["matches"] (ReqArg (NumMatches . read) "N") + Option ['n'] ["matches"] (ReqArg (NumMatches . read) "N") "number of matches (for AI tournaments)", Option ['d'] ["dir"] (ReqArg DataDir "DATADIR") "data directory",- Option ['t'] ["tests"] (NoArg RunTests) + Option ['t'] ["tests"] (NoArg RunTests) "run QuickCheck tests" ] parseArgs :: [String] -> IO ([Flag],[String])-parseArgs argv +parseArgs argv = case getOpt Permute options argv of (flags, argv', []) -> return (flags, argv')- (_, _, errs) -> ioError $ - userError $ + (_, _, errs) -> ioError $+ userError $ concat errs ++ usageInfo header options ++ footer- + header, footer :: String-header = "usage: hstzaar [OPTION..] [AI] [AI]"-footer = "\twhere AI is one of: " ++ unwords (map name aiPlayers)+header = "usage: hstzaar [OPTION..] [AI AI]"+footer = "\twhere AI is one of: " ++ unwords (map (show.name) aiPlayers) -- default number of matches for AI tournaments@@ -55,16 +54,15 @@ matches = 10 processFlags :: [Flag] -> IO ()-processFlags = mapM_ process - where +processFlags = mapM_ process+ where process RunTests = run_tests >> exitSuccess- process (Seed s) = setStdGen (mkStdGen s) + process (Seed s) = setStdGen (mkStdGen s) process _ = return () main :: IO () main = do argv<-getArgs- rnd <- getStdGen (flags, argv')<- parseArgs argv processFlags flags dir <- getDataDir@@ -73,33 +71,15 @@ -- case argv' of [] -> gui gladepath- [arg1] -> case lookupAI arg1 aiPlayers of- Nothing -> ioError $ - userError $ "invalid AI: " ++ arg1- Just ai -> - do { txt <- getContents -- read start position- ; case readXML txt of - Nothing -> putStrLn "ERROR: couldn't parse game file"- Just g -> playAI rnd ai (board g) - }- [arg1,arg2] -> + [arg1,arg2] -> case do p1 <- lookupAI arg1 aiPlayers p2 <- lookupAI arg2 aiPlayers return (p1,p2)- of Nothing -> ioError $ + of Nothing -> ioError $ userError $ "invalid AI: " ++ unwords [arg1, arg2] Just (p1,p2) ->- do let (boards, rnd') = randomBoards numMatches rnd+ do rnd <- getStdGen+ let (boards, rnd') = randomBoards numMatches rnd setStdGen rnd' playAIs p1 p2 boards rnd _ -> ioError $ userError $ usageInfo header options ++ footer-----playAI :: StdGen -> AI -> Board -> IO ()-playAI rnd ai b - | endGame b = putStrLn ("Game end (" ++ show (invert $ active b) ++ " won)")- | otherwise = putStrLn (show (active b) ++ ": " ++ showMove m)- where (score, m, _) = playing ai b rnd-
src/Serialize.hs view
@@ -1,24 +1,24 @@--- Serialization of Tzaar games to/from XML +-- Serialization of Tzaar games to/from XML -- Pedro Vasconcelos, 2012 module Serialize where import Data.Version import Paths_hstzaar(version) import Data.Maybe import Text.XML.Light-import qualified Data.Map as Map+-- import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HashMap import Board-import Control.Monad -- | convertion to/from XML elements class ToXML a where toXML :: a -> Element- -class FromXML a where ++class FromXML a where fromXML :: Element -> Maybe a --- | wrapper for a piece together with a board position -newtype PosPiece = PosPiece (Position, Piece) +-- | wrapper for a piece together with a board position+newtype PosPiece = PosPiece (Position, Piece) deriving (Eq,Show) -- | wrapper for a list of moves from game start@@ -28,8 +28,8 @@ newtype NumMove = NumMove (Int,Color,Move) deriving (Eq,Show) instance Node PosPiece where- node qn (PosPiece (pos,(c,k,h))) = add_attrs alist $ node qn ()- where alist = [attr "color" (show c), + node qn (PosPiece (pos,(Piece c k h))) = add_attrs alist $ node qn ()+ where alist = [attr "color" (show c), attr "kind" (show k), attr "height" (show h), attr "position" (show pos)]@@ -48,13 +48,12 @@ instance Node Board where- node qn b = -- add_attr (attr "active" (show $ active b)) $- node qn $ - map (Elem . node (unqual "piece") . PosPiece) $ - Map.assocs (pieces b)+ node qn b = node qn $+ map (Elem . node (unqual "piece") . PosPiece) $+ HashMap.toList (pieces b) instance Node Game where- node qn g = add_attrs alist $ + node qn g = add_attrs alist $ node qn [Elem (node (unqual "board") (initial g)), Elem (node (unqual "moves") (MoveList ms))] where ms = reverse (trail g) ++ remain g -- all moves@@ -63,35 +62,34 @@ instance ToXML Game where- toXML = node (unqual "hstzaar") + toXML = node (unqual "hstzaar") -instance FromXML Board where - -- defaults to White active player +instance FromXML Board where fromXML el = return (initBoard assocs) where assocs = catMaybes- [do { c<-readAttr (unqual "color") el' + [do { c<-readAttr (unqual "color") el' ; k<-readAttr (unqual "kind") el' ; h<-readAttr (unqual "height") el' ; pos<-readAttr (unqual "position") el'- ; return (pos,(c,k,h))+ ; return (pos, Piece c k h) } | el'<-findChildren (unqual "piece") el]- + instance FromXML MoveList where- fromXML el = liftM MoveList $ - sequence [ readMove (strContent el') - | el'<-findChildren (unqual "move") el]+ fromXML el = Just (MoveList moves)+ where moves = catMaybes+ [ readMove (strContent el')+ | el'<-findChildren (unqual "move") el] instance FromXML Game where fromXML el = do el1 <- findChild (unqual "board") el el2 <- findChild (unqual "moves") el+ c <- readAttr (unqual "human") el -- human player color b <- fromXML el1 MoveList ms <- fromXML el2- c <- readOptAttr White (unqual "human") el -- human player color let g = initGame b c- -- let b'= foldr applyMoveSkip b (reverse ms)- b' <- foldM applyMoveSkip' b ms+ let b' = foldr applyMoveSkip b (reverse ms) return g { board=b', trail=reverse ms } @@ -99,33 +97,27 @@ showXML a = ppTopElement (toXML a) readXML :: FromXML a => String -> Maybe a-readXML txt = parseXMLDoc txt >>= fromXML +readXML txt = parseXMLDoc txt >>= fromXML -- | parse an attribute from an element-readAttr :: Read a => QName -> Element -> Maybe a -readAttr name el = do txt<-findAttr name el +readAttr :: Read a => QName -> Element -> Maybe a+readAttr name el = do txt<-findAttr name el case reads txt of [] -> Nothing (a,_):_ -> Just a -readOptAttr :: Read a => a -> QName -> Element -> Maybe a-readOptAttr def name el - = case findAttr name el of - Nothing -> Just def- Just txt -> case reads txt of [] -> Nothing- (a,_):_ -> Just a readMove :: String -> Maybe Move readMove [a,b,'x',c,d] = do (from,_) <- listToMaybe (reads [a,b]) (to,_) <- listToMaybe (reads [c,d]) return (Capture from to)- + readMove [a,b,'-',c,d] = do (from,_) <- listToMaybe (reads [a,b]) (to,_) <- listToMaybe (reads [c,d]) return (Stack from to)-readMove "pass" = Just Pass +readMove "pass" = Just Pass readMove "skip" = Just Skip readMove _ = Nothing @@ -133,10 +125,8 @@ -- | make an attribute with an unqualified name attr :: String -> String -> Attr-attr n = Attr (unqual n) +attr n = Attr (unqual n) -- | make a cdata from a string cdata :: String -> CData cdata txt = CData CDataText txt Nothing--
src/Tests.hs view
@@ -3,12 +3,14 @@ Pedro Vasconcelos, 2010, 2011 -} module Tests where-import Board +import Board --import AI.Tree import AI.Eval import AI.Minimax import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set+import qualified Data.Vector.Unboxed as Vec import Data.List (delete, nub, sort) import Control.Monad (liftM) @@ -28,18 +30,18 @@ -- default generator and counter-example shrinker for boards instance Arbitrary Board where- arbitrary = sized genBoard - + arbitrary = sized genBoard+ {- shrink board = [board {active=you} | you<-shrinkHalf (active board)] ++- [board {inactive=other} | other<-shrinkHalf (inactive board)] + [board {inactive=other} | other<-shrinkHalf (inactive board)] -- helper function to shrink half-boards -- first try to remove pieces, then reduce heights shrinkHalf :: HalfBoard -> [HalfBoard] shrinkHalf b = [Map.delete p b | p<-Map.keys b] ++- [Map.insert p (t,h') b | + [Map.insert p (t,h') b | (p,(t,h))<-Map.assocs b, h'<-[1..h-1]] -} @@ -48,7 +50,7 @@ -- size argument is a bound for the total number of pieces -- always generates board with the 3 kinds for each player genBoard :: Int -> Gen Board-genBoard size +genBoard size = do ws <- genStacks White n bs <- genStacks Black n ps <- genShuffle positions@@ -56,31 +58,31 @@ --m <- choose (1, n) let whites = zip (take n ps) ws let blacks = zip (drop n ps) bs- let pmap = Map.fromList (whites++blacks) + let pmap = HashMap.fromList (whites++blacks) return Board { active = c , move = 0- , moves = []+ -- , moves = [] , pieces = pmap- , activeCounts = countStacks c pmap- , inactiveCounts = countStacks (invert c) pmap- , activeHeights = sumHeights c pmap- , inactiveHeights= sumHeights (invert c) pmap- } + , activeCounts = Vec.fromList $ countStacks c pmap+ , inactiveCounts = Vec.fromList $ countStacks (invert c) pmap+ , activeHeights = Vec.fromList $ sumHeights c pmap+ , inactiveHeights= Vec.fromList $ sumHeights (invert c) pmap+ } where n = 3 `max` (size`div`2) `min` 30 -- between 3 and 30 stacks- - ++ -- generate piece stacks genStacks :: Color -> Int -> Gen [Piece]-genStacks c n +genStacks c n = do ps <- liftM ([Tzaar,Tzarra,Tott]++) (genShuffle pieces) hs <- sequence [choose (1,maxHeight) | _<-[1..n]]- return (zip3 (repeat c) ps hs)- where pieces = replicate 5 Tzaar ++ - replicate 8 Tzarra ++ + return (zipWith3 Piece (repeat c) ps hs)+ where pieces = replicate 5 Tzaar +++ replicate 8 Tzarra ++ replicate 14 Tott maxHeight = 5- + -- generate random permutations of a list genShuffle :: Eq a => [a] -> Gen [a] genShuffle [] = return []@@ -90,7 +92,7 @@ ------------------------------------------------------------------------------ Quickcheck properties +-- Quickcheck properties --------------------------------------------------------------------------- -- properties of the game mechanics@@ -110,50 +112,50 @@ -- stacking mantains the sum of pieces heights of the active player prop_stacking_moves2 :: Board -> Bool prop_stacking_moves2 b- = and [ heights (pieces b) == heights (pieces b') + = and [ heights (pieces b) == heights (pieces b') | m <- stackingMoves b, let b'=applyMove m b]- where + where c = active b -- the current player- heights ps = sum [h | (c',_,h)<-Map.elems ps, c'==c]+ heights ps = sum [h | (Piece c' _ h)<-HashMap.elems ps, c'==c] -- stacking does not modify opponents pieces prop_stacking_moves3 :: Board -> Bool prop_stacking_moves3 b- = and [ Map.filter (\p->color p==c') (pieces b') == - Map.filter (\p->color p==c') (pieces b)+ = and [ HashMap.filter (\p->color p==c') (pieces b') ==+ HashMap.filter (\p->color p==c') (pieces b) | m <- stackingMoves b, let b'=applyMove m b]- where + where c = active b -- the current player c'= invert c -- the other player prop_swap_swap :: Board -> Bool-prop_swap_swap b = swapBoard (swapBoard b) == b+prop_swap_swap b = swapPlayer (swapPlayer b) == b prop_active_counts :: Board -> Bool prop_active_counts b- = and [activeCounts b' == countStacks (active b') (pieces b')+ = and [activeCounts b' == Vec.fromList (countStacks (active b') (pieces b')) | m<-nextMoves b, let b'=applyMove m b]- + prop_inactive_counts :: Board -> Bool prop_inactive_counts b- = and [inactiveCounts b' == countStacks (inactive b') (pieces b')+ = and [inactiveCounts b' == Vec.fromList (countStacks (inactive b') (pieces b')) | m<-nextMoves b, let b'=applyMove m b]- - ++ prop_active_heights :: Board -> Bool prop_active_heights b- = and [activeHeights b' == sumHeights (active b') (pieces b')+ = and [activeHeights b' == Vec.fromList (sumHeights (active b') (pieces b')) | m<-nextMoves b, let b'=applyMove m b]- + prop_inactive_heights :: Board -> Bool prop_inactive_heights b- = and [inactiveHeights b' == sumHeights (inactive b') (pieces b')+ = and [inactiveHeights b' == Vec.fromList (sumHeights (inactive b') (pieces b')) | m<-nextMoves b, let b'=applyMove m b]- - ++ -- correctness of the zone of control computation -- the zone of control is the set of pieces -- that can be captured in a turn (one or two moves)@@ -161,37 +163,37 @@ prop_zoc_correct b = pos == pos' where moves1 = captureMoves b- moves2 = concat [captureMoves (swapBoard (applyMove m b)) | m<-moves1]+ moves2 = concat [captureMoves (swapPlayer (applyMove m b)) | m<-moves1] pos = Set.fromList [dest | Capture _ dest<-(moves1++moves2)]- pos'= Map.keysSet (zoneOfControl (active b) (pieces b))+ pos'= Set.fromList $ HashMap.keys $ zoneOfControl (active b) (pieces b) --------------------------------------------------------------------------- -- properties of the AI code --------------------------------------------------------------------------- --- | a trace is a sequence of game positions +-- | a trace is a sequence of game positions newtype Trace = Trace { unTrace :: [Board] } deriving Show instance Arbitrary Trace where- arbitrary = do b <- arbitrary + arbitrary = do b <- arbitrary liftM Trace (genTrace b)- --- | generate a sequence random board resulting ++-- | generate a sequence random board resulting -- from valid moves from a starting board genTrace :: Board -> Gen [Board]-genTrace b +genTrace b | null ms = return [b] | otherwise = do m <- elements ms bs <- genTrace (applyMove m b) return (b:bs) where ms = nextMoves b- + -- | players must alternate in a trace-prop_trace_alternating (Trace bs) +prop_trace_alternating (Trace bs) = let players = map active bs in and $ zipWith (/=) players (tail players) @@ -200,11 +202,11 @@ prop_trace_ending (Trace bs) = let b' = last bs bs'= init bs- in all threekinds bs' && + in all threekinds bs' && (lostone b' || null (nextMoves b')) where threekinds b = all (>0) (countStacks (active b) (pieces b) ++ countStacks (inactive b) (pieces b))- lostone b = any (==0) (countStacks (active b) (pieces b)) + lostone b = any (==0) (countStacks (active b) (pieces b)) -- | upper and lower bounds for the evaluation function@@ -214,21 +216,21 @@ {---- correcteness of alpha-beta pruning against plain minimax --- parameters: number of pieces, pruning depth +-- correcteness of alpha-beta pruning against plain minimax+-- parameters: number of pieces, pruning depth prop_alpha_beta :: Int -> Board -> Bool-prop_alpha_beta d b +prop_alpha_beta d b = let bt = pruneDepth d $ mapTree eval1 $ boardTree b in negamax_alpha_beta (minBound+1) maxBound bt == negamax bt- + -- correctness of alpha-beta minimax extended with principal variation--- parameters: number of pieces, pruning depth +-- parameters: number of pieces, pruning depth prop_alpha_beta_pv :: Int -> Board -> Bool prop_alpha_beta_pv d b = let bt = pruneDepth d $ mapTree eval1 $ boardTree b PV v ms = undefined -- negamaxPV bt- n = length ms + n = length ms b' = foldl (flip applyMove) b ms v' = eval1 b' in (-1)^n * v' == v@@ -239,7 +241,7 @@ -- end game positions give plus/minus infinity scores prop_inactive_lost :: Eval -> Board -> Property prop_inactive_lost f b- = not (active_lost b) && inactive_lost b ==> f b == infinity + = not (active_lost b) && inactive_lost b ==> f b == infinity prop_active_lost :: Eval -> Board -> Property prop_active_lost f b@@ -257,20 +259,20 @@ wellformedTree :: GameTree Board Move -> Bool wellformedTree (GameTree b branches)- = and [player b /= player b' && + = and [player b /= player b' && wellformedTree t | (m,t@(GameTree b' _)) <- branches] - + -- helper functions to filter boards, etc. -- "admissible" boards: no winner yet admissible :: Board -> Bool admissible b = not (active_lost b) && not (inactive_lost b) active_lost, inactive_lost :: Board -> Bool-active_lost b - = (move b==1 && null (captureMoves b)) || +active_lost b+ = (move b==1 && null (captureMoves b)) || any (==0) (countStacks $ active b) inactive_lost b = any (==0) (countStacks $ inactive b)@@ -312,4 +314,4 @@ -quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n}) +quickCheckN n = quickCheckWith (stdArgs{maxSuccess=n})
src/Tournament.hs view
@@ -6,50 +6,52 @@ import AI.Gametree import System.Random import Control.Monad+import Control.Monad.State --- compare two strategies on a starting board ++-- compare two strategies on a starting board -- plays 2 games with either strategy first and sums the results -- result is 1 or -1 according to the winner playMatch :: Board -> StdGen -> AI -> AI -> IO Int playMatch b rnd p1 p2- | is_terminal b = return (-1) -- p1 can't play, p2 wins+ | isTerminal b = return (-1) -- p1 can't play, p2 wins | otherwise = do putStrLn line liftM negate $ playMatch b' rnd' p2 p1- where (score, m, rnd') = playing p1 b rnd- line = show (move b) ++ ". " ++ show (active b) ++ + where ((m, score), rnd') = runState (strategy p1 b) rnd+ line = show (move b) ++ ". " ++ show (active b) ++ " ("++name p1 ++ "):\t" ++ " " ++- showMove m ++ "\tscore: " ++ show score+ showMove m ++ "\t" ++ show score b' = applyMove m b -- compare two strategies on random boards playAIs :: AI -> AI -> [Board] -> StdGen -> IO ()-playAIs p1 p2 boards rnd +playAIs p1 p2 boards rnd = do rs<-sequence [do { header i ; r<-playMatch b rnd p1 p2 ; hline ; r'<-playMatch b rnd p2 p1 ; hline- ; return (r-r') - } - | (i,b)<-zip [1..] boards] + ; return (r-r')+ }+ | (i,b)<-zip [1..] boards] let won = sum [r | r<-rs, r>0] let lost= - sum [r | r<-rs, r<0] let score = sum rs- putStrLn (name p1 ++ " vs " ++ name p2 ++ ": " - ++ show score ++ " (" - ++ show won ++ " matches won and " + 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 n) hline = putStrLn (replicate 70 '-') --- create random boards +-- create random boards randomBoards :: Int -> StdGen -> ([Board], StdGen) randomBoards 0 rndgen = ([], rndgen)-randomBoards n rndgen +randomBoards n rndgen | n>0 = (b:bs, rndgen'') where (b, rndgen') = randomBoard rndgen (bs, rndgen'') = randomBoards (n-1) rndgen'