hstzaar 0.9.1 → 0.9.2
raw patch · 12 files changed
+336/−335 lines, 12 filesdep +paralleldep −haskell98
Dependencies added: parallel
Dependencies removed: haskell98
Files
- RELEASE-NOTES +9/−0
- hstzaar.cabal +7/−7
- src/AI.hs +66/−30
- src/AI/Eval.hs +18/−10
- src/AI/Gametree.hs +56/−0
- src/AI/Minimax.hs +114/−66
- src/AI/Tree.hs +0/−169
- src/Board.hs +10/−5
- src/GUI.hs +17/−11
- src/Main.hs +14/−13
- src/Tests.hs +21/−20
- src/Tournament.hs +4/−4
RELEASE-NOTES view
@@ -1,3 +1,12 @@+0.9.2 30/08/2012+- removed bogus dependency on haskell98 package+- changed AI code to use a type class for generating gametrees; + this should prevent space leaks on game state search+- parametrized minimax algorithms on the valuation functions; + currently we allow simple (material only) and full (material+positional) valuations+- implemented negascout and parallel negascout (aka "Jamboree") algorithm;+ parallelism achieves moderate speed-up (2x on a quad-core desktop)+ hstzaar 0.9.1 25/03/2012 - bug fix in open game (check for end of game condition)
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.9.1+version: 0.9.2 category: Game @@ -13,7 +13,7 @@ by Tom Hawkins <tomahawkins@gmail.com>. author: Pedro Vasconcelos <pbv@dcc.fc.up.pt>-maintainer: Pedro Vasconcelos <pbv@fcc.fc.up.pt>+maintainer: Pedro Vasconcelos <pbv@dcc.fc.up.pt> license: BSD3 license-file: LICENSE@@ -30,13 +30,13 @@ executable hstzaar hs-source-dirs: src main-is: Main.hs- other-modules: GUI Serialize Board AI AI.Tree AI.Eval AI.Minimax Tournament Tests+ other-modules: GUI Serialize Board AI AI.Gametree AI.Eval AI.Minimax Tournament Tests build-depends:- base >= 4 && < 5,- haskell98,+ base >= 4 && <5, filepath >= 1.1, directory >= 1.0, containers,+ parallel >= 2.0, gtk >=0.11, cairo >= 0.11, glade >= 0.11,@@ -44,5 +44,5 @@ QuickCheck >= 2.1, xml >= 1.3 - ghc-options: -threaded - ghc-prof-options: -prof -auto-all+ ghc-options: -threaded -rtsopts + ghc-prof-options: -prof -auto-all
src/AI.hs view
@@ -1,41 +1,77 @@--- | Library of AI Players-module AI (aiPlayers) where+--+-- Library of AI players+--+module AI where import Board-import AI.Tree+import System.Random+import Data.Map(Map)+import qualified Data.Map as Map+import Data.Maybe(catMaybes)+import AI.Gametree import AI.Minimax-import AI.Eval--- import Debug.Trace+import AI.Eval --- all AI players; ply depth >1 do not necessarily play better!-aiPlayers :: [(String,AI)]-aiPlayers = [ (l,ply l d) | n<-[0..3], let d=max 1 (2*n+1), let l="Level "++show n] -{-+-- | instance the gametree class for TZAAR +instance Gametree Board where+ children b = [applyMove m b | m<-nextMoves b]+ is_terminal b = null (nextMoves b) -aiPlayers = zipWith (\n ai -> (n,ai n)) names levels- where levels = basic : [ply (3*n) | n<-[1,2,3]]- names = ["Level " ++ show n | n<-[0..3]]+-- | 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) --- basic AI: material evaluation, depth 1-basic n = AI { name = n- , description = "Minimax alpha-beta depth 3"- , strategy = negamaxStrategy 3 eval0- }--}+-- | An AI player.+data AI = AI+ { name :: String -- ^ Unique name+ , description :: String -- ^ Brief description of AI.+ , playing :: Playing -- ^ The play strategy.+ } --- better AI, parameterized by ply depth-ply :: String -> Int -> AI-ply n d = AI { name = n- , description = "Minimaxing with alpha-beta ply " ++ show d- , strategy = singleMoves $ negamaxStrategy d eval1- {-- withBoard $ - \b -> let m = minimum (countStacks (active b) (pieces b) ++- countStacks (inactive b) (pieces b))- d' = if m<=3 then d else 3- in negamaxStrategy d' eval1 -}- }+++aiLevels :: [AI]+aiLevels = catMaybes [lookupAI label aiPlayers | label<-list]+ where list = ["nscout_simple_1", + "nscout_simple_3",+ "nscout_full_1", + "nscout_full_3", + "nscout_full_6", + "pscout_full_3", + "pscout_full_6"]+++lookupAI :: String -> [AI] -> Maybe AI+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]+ 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)+ }+ 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
src/AI/Eval.hs view
@@ -1,17 +1,25 @@ {-# LANGUAGE BangPatterns #-}+-- -- Static evaluation functions for board positions-module AI.Eval where+--+module AI.Eval (simple_val, full_val) where import Board-import AI.Tree (infinity)+import AI.Gametree --- | Static board evaluation function --- considers material and positional scores-eval1 :: Board -> Int-eval1 b- | null moves = -infinity--- | any (==0) counts' = infinity -- this should *NOT* be necessary - | otherwise = material b + positional b- where moves = nextMoves b -- active player's moves++-- simple static board valuation (material score only)+simple_val :: Valuation Board+simple_val b = if null (nextMoves b) then lost 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 +++-- 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
+ src/AI/Gametree.hs view
@@ -0,0 +1,56 @@+--+-- Type class for traversing AI 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++-- | type for valuation functions +type Valuation a = a -> Int+++-- | 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++instance Functor Valued where+ fmap f (Valued v x) = Valued v (f x)++-- | apply a valuation +valued :: Valuation a -> a -> Valued a+valued f x = Valued (f x) x++-- | modify the valuation+revalue :: (Int -> Int) -> Valued a -> Valued a+revalue f (Valued v x) = Valued (f v) x++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+ (-) = undefined+ (*) = undefined+ negate = revalue negate+ fromInteger n = valued (const (fromIntegral n)) undefined+ abs = undefined+ signum = undefined+++-- | add a constant to a value+infix 6 $++($+) :: Int -> Valued a -> Valued a+k $+ x = revalue (+k) x++
src/AI/Minimax.hs view
@@ -1,85 +1,133 @@ {-# LANGUAGE BangPatterns #-}-module AI.Minimax( negamaxStrategy- , negamax- , negamax_ab- , negamaxPV- ) where+module AI.Minimax ( negamax+ , negamax_alpha_beta+ , negascout+ , jamboree+ ) where -import AI.Tree import Board--- import Debug.Trace+import AI.Gametree+import Control.Parallel.Strategies --- | Negamax with alpha-beta and static depth prunning -negamaxStrategy :: Int -> Eval -> Strategy-negamaxStrategy depth eval bt rndgen - | isEmptyTree bt = error "negamaxStrategy: empty tree"-negamaxStrategy depth eval bt rndgen - = (score, m, rndgen)- where (score, m:_) = negamaxPV $ - pruneDepth depth $ -- ^ prune evaluation tree- mapTree eval bt -- ^ apply static evaluation function+-- | Naive negamax algorithm (no prunning)+-- wrapper+negamax :: Gametree p => Valuation p -> Int -> p -> Valued p+negamax node_value depth p = negamax' depth p+ 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 +-- | 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+ 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 --- | Naive negamax algorithm (not used)--- | nodes values are static evaluation scores-negamax :: (Num a, Ord a) => GameTree a m -> a -negamax (GameTree x []) = x-negamax (GameTree _ branches) = - minimum vs- where vs = map (negamax . snd) branches +-- | 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 +-- 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+ | b >= beta = b+ | otherwise = scout (max alfa b) b ps+ 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)+ | 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 = s+ alfa' = max alfa s'+ b' = max b s'+ --- | Negamax with alpha-beta prunning; --- computes the minimax value but not the best move-negamax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a-negamax_ab a b (GameTree x []) = a `max` x `min` b-negamax_ab a b (GameTree _ branches) = cmx a b (map snd branches)- where cmx a b [] = a- cmx a b (t:ts) | a'==b = a'- | otherwise = cmx a' b ts- where a' = - negamax_ab (-b) (-a) t+-- | 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 +-- worker+jamboree' node_value d alfa beta p+ | d<=1 = negascout' node_value d alfa beta p+ -- use sequencial version for low depth+ | is_terminal p = valued node_value 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 + scout p + | s >= beta = Cutoff s + | s > alfa' = Search p+ | otherwise = OK+ where s = negate $ jamboree' node_value d' (negate (1$+alfa')) (negate alfa') 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 --- | pair a evaluation score with something-newtype PV a = PV (Int,a) deriving (Show)+ -- sequential full search for scout failures+ search !alfa !b [] = b+ search !alfa !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 -instance Eq (PV a) where- (PV (x,_)) == (PV (y,_)) = x==y -instance Ord (PV a) where- compare (PV (x,_)) (PV (y,_)) = compare x y -instance Show a => Num (PV a) where- (+) = undefined- (-) = undefined- (*) = undefined- fromInteger = undefined- signum = undefined- abs = undefined- negate (PV (x,m)) = PV (negate x,m)----- | Negamax with alpha-beta pruning--- computes both minimax value and the best move (start of principal variation)-negamaxPV :: GameTree Int Move -> (Int, [Move])-negamaxPV bt- = case negamaxPV_ab [] lo hi bt of- PV (v,ms) -> (v,reverse ms)- where lo = PV (-infinity, []) -- dummy bounds- hi = PV ( infinity, [])- -- m = fst (head branches)+-- | 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') -negamaxPV_ab :: [Move] -> PV [Move] -> PV [Move] -> GameTree Int Move -> PV [Move]-negamaxPV_ab ms a b (GameTree x []) = a `max` (PV (x,ms)) `min` b-negamaxPV_ab ms a b (GameTree _ branches) = cmx a b branches- where - cmx x y [] = x- cmx x y ((m,t) : rest) - | x'==y = x'- | otherwise = cmx x' y rest- where x' = - negamaxPV_ab (m:ms) (-y) (-x) t -
− src/AI/Tree.hs
@@ -1,169 +0,0 @@--- | Utilities for computing AI game trees-module AI.Tree- ( BoardTree- , GameTree(..)- , Strategy- , AI (..)- , Eval- , boardTree- -- , startBoardTree- , mapTree- , mapTree'- , isEmptyTree- , infinity- -- , winOrPreventLoss- , pruneDepth, pruneBreadth- , highFirst, lowFirst- , withBoard- , singleMoves- -- , dontPass, singleCaptures - ) where--import Board-import Data.List (nubBy, sortBy, minimumBy)-import qualified Data.Map as Map-import System.Random---- | A game tree with nodes s and moves m-data GameTree s m = GameTree s [(m, GameTree s m)] - deriving Show---- | 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]---- | test for empty branches-isEmptyTree :: GameTree a m -> Bool-isEmptyTree (GameTree _ []) = True-isEmptyTree _ = False----- | A game tree of boards labeled by moves-type BoardTree = GameTree Board Move---- | An AI strategy calculates the next turn from a board tree.--- result: evaluation score, next move, next random generator-type Strategy = BoardTree -> StdGen -> (Int, Move, StdGen)---- | An AI player.-data AI = AI- { name :: String -- ^ Name of AI.- , description :: String -- ^ Brief description of AI.- , strategy :: Strategy -- ^ The strategy.- }---- | type of static evaluation functions-type Eval = Board -> Int ---- | maximum absolute value of static evaluation -infinity :: Int-infinity = 2^20----- | Create a board tree from a board position-boardTree :: Board -> BoardTree-boardTree b = GameTree b [(m, boardTree (applyMove m b)) | m<-nextMoves b]----- | order subtrees with ascending or descending order (not used)-highFirst, lowFirst :: GameTree Int m -> GameTree Int m-highFirst (GameTree x branches) - = GameTree x [(m,highFirst t) | (m,t)<-sortBy cmp branches] - where cmp (_,x) (_,y) = compare (value y) (value x)- value (GameTree n _) = n--lowFirst (GameTree x branches) - = GameTree x [(m,lowFirst t) | (m,t)<-sortBy cmp branches]- where cmp (_,x) (_, y) = compare (value x) (value y)- value (GameTree n _) = n------ | prune a game tree to a fixed depth-pruneDepth :: Int -> GameTree a m -> GameTree a m-pruneDepth n (GameTree x branches) - | n>0 = GameTree x [(m,pruneDepth (n-1) t) | (m,t)<-branches]- | otherwise= GameTree x []----- | prune a game tree to a fixed breadth (not used)-pruneBreadth :: Int -> GameTree a m -> GameTree a m-pruneBreadth k (GameTree node branches) - = GameTree node [(m,pruneBreadth k t) | (m,t)<-take k branches]--- --- | conditional strategy (depending on the board state)-withBoard :: (Board -> Strategy) -> Strategy-withBoard f t@(GameTree b _) g = f b t g---- number of stacks of both players--- withStacks :: (Int -> Strategy) -> Strategy--- withStacks f = withBoard $ \b -> f (IntMap.size (active b) + IntMap.size (inactive b))---- | avoid search when only move is available-singleMoves :: Strategy -> Strategy-singleMoves s (GameTree b [(m,_)]) rnd = (0, m, rnd)-singleMoves s bt rnd = s bt rnd---{---- | Searches BoardTree to a depth of 1 looking for a --- | guaranteed win or a preventable loss.-winOrPreventLoss :: Strategy -> Strategy-winOrPreventLoss s (GameTree node branches) = s $ GameTree node branches2- where- -- ensure a win in 1 or 2 captures- winning = [ (m, t) | (m,t@(GameTree b _))<-branches, endGame b]- -- prevent a loss- prevent_loss = [(m1,t1) | (m1,t1@(GameTree _ branches'))<-branches,- (m2,t2)<- branches', not_losing t2]- - branches1 = (if not (null winning) - then [head winning]- else prevent_loss- )- branches2 = if null branches1 then [head branches] else branches1- not_losing (GameTree _ branches) - = null [m | (m, GameTree b _) <- branches, endGame b]- cutoff = 1000 -- braching upper bound for searching losing 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- | otherwise = s g' rndgen- where- g'@(GameTree _ branches') = narrow g- narrow :: BoardTree -> BoardTree- narrow (GameTree board branches)- = GameTree board [ (m, narrow g) | (m,g)<-branches,- move board==1 || isStacking m ]- isStacking (Stack _ _) = True- isStacking _ = False---- don't consider passing moves -dontPass :: Strategy -> Strategy-dontPass s g rndgen = s (narrow g) rndgen- where- narrow :: BoardTree -> BoardTree- narrow (GameTree node branches) - | null branches' = GameTree node branches- | otherwise = GameTree node branches'- where branches' = [(m, narrow g) | (m,g)<-branches, m/=Pass]--}------
src/Board.hs view
@@ -98,6 +98,7 @@ 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@@ -110,7 +111,7 @@ initBoard :: [(Position,Piece)] -> Board initBoard assocs = let ps = Map.fromList assocs- in Board { active=White, move=0, pieces=ps,+ in Board { active=White, move=0, moves=[], pieces=ps, activeCounts=countStacks White ps, inactiveCounts=countStacks Black ps, activeHeights=sumHeights White ps,@@ -121,6 +122,7 @@ inactive = invert . active + -- | 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@@ -191,7 +193,7 @@ = case (m-1)`mod`3 of 0 -> captureMoves b -- first move 1 -> [Skip] -- dummy opponent move within a turn- 2 -> Pass : (captureMoves b ++ stackingMoves b) -- second moves+ 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@@ -281,9 +283,10 @@ -- | The next board state after a move. -- | Assumes the move is valid. applyMove :: Move -> Board -> Board-applyMove (Capture x y) b +applyMove m@(Capture x y) b = b {active=invert (active b), move=1+move b, + moves = m:moves b, pieces= pieces', activeCounts = counts', -- swap counts inactiveCounts= activeCounts b,@@ -298,9 +301,10 @@ heights'= increment kindY (-sizeY) (inactiveHeights b) -applyMove (Stack x y) b +applyMove m@(Stack x y) b = b {active=invert (active b), move=1+move b, + moves= m:moves b, pieces=pieces', activeCounts = inactiveCounts b, inactiveCounts = counts',@@ -318,8 +322,9 @@ -- Pass & Skip have the same effect-applyMove _ b = b {active= invert (active b), +applyMove m b = b {active= invert (active b), move=1+move b, + moves= m:moves b, activeCounts= inactiveCounts b, inactiveCounts= activeCounts b, activeHeights= inactiveHeights b,
src/GUI.hs view
@@ -20,8 +20,8 @@ import System.Random hiding (next) import Board import AI-import AI.Tree-import AI.Eval+--import AI.Tree+--import AI.Eval -- import History (History) -- import qualified History as History import Serialize -- convert to/from XML @@ -74,7 +74,7 @@ menu_item_show_moves :: CheckMenuItem, -- menu_item_random_start :: CheckMenuItem, -- menu_item_human :: CheckMenuItem,- menu_item_ai_players :: [(RadioMenuItem, AI)],+ menu_item_ai_levels :: [RadioMenuItem], menu_item_about :: MenuItem, open_file_chooser :: FileChooserDialog, save_file_chooser :: FileChooserDialog,@@ -115,14 +115,18 @@ bd <- drawingAreaNew containerAdd fr bd m<- xmlGetWidget xml castToMenu "menu_ai"- r <- radioMenuItemNewWithLabel (name $ snd $ head aiPlayers)+ tips<-tooltipsNew+ r <- radioMenuItemNewWithLabel (name (head aiLevels))+ tooltipsSetTip tips r (description (head aiLevels)) "" menuAttach m r 0 1 0 1- rs@(r1:_) <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t) + rs@(r1:_) <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name ai)+ tooltipsSetTip tips w (description ai) "" menuAttach m w 0 1 i (i+1) return w- | (t,i)<-zip (tail aiPlayers) [1..]]- -- select default AI + | (i,ai)<-zip [1..] (tail aiLevels)]+ -- select default AI: this is hardcoded to be the *second* entry checkMenuItemSetActive r1 True+ tooltipsEnable tips -- open/save file dialogs ff <- fileFilterNew fileFilterSetName ff "Tzaar saved games (*.tza)"@@ -136,7 +140,7 @@ cid <- statusbarGetContextId sb "status" widgetShowAll mw return (GUI mw bd abd std fixp playw playb sb pb mn mo ms mq mun mre mpa mds- msh msm (zip (r:rs) (map snd aiPlayers)) mab opf svf cid)+ msh msm (r:rs) mab opf svf cid) -- | main GUI entry point gui :: FilePath -> IO ()@@ -243,8 +247,10 @@ -- | get the selected AI player getAI :: GUI -> IO AI getAI gui - = do rs<-filterM (checkMenuItemGetActive . fst) (menu_item_ai_players gui)- return $ snd (head (rs ++ error "getAI: no AI selected"))+ = 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@@ -391,7 +397,7 @@ runAI ai b mvar = do { threadDelay (200*1000) -- short delay to allow GUI redraw ; rnd <- getStdGen- ; let (score, m, rnd') = strategy ai (boardTree b) rnd+ ; let (score, m, rnd') = playing ai b rnd ; setStdGen rnd' -- ; putStrLn ("AI move: "++show m ++ " score: " ++ show score) ; m `seq` putMVar mvar m
src/Main.hs view
@@ -5,19 +5,18 @@ import Paths_hstzaar import Board import AI-import AI.Tree import GUI import Tournament import Tests import Data.List (intersperse)-import System+import System.Environment import System.Random import System.Console.GetOpt import System.Exit import Control.Monad (when) import System.Directory import System.FilePath-+import qualified Data.Map as Map data Flag = Seed Int | NumMatches Int @@ -47,7 +46,7 @@ header, footer :: String header = "usage: hstzaar [OPTION..] [AI AI]"-footer = "\twhere AI is one of: " ++ unwords (map fst aiPlayers)+footer = "\twhere AI is one of: " ++ unwords (map (show.name) aiPlayers) -- default number of matches for AI tournaments@@ -72,16 +71,18 @@ -- case argv' of [] -> gui gladepath- [a1,a2] | a1`elem`ais && a2`elem`ais-> - do rnd <- getStdGen- let (boards, rnd') = randomBoards numMatches rnd- setStdGen rnd'- playAIs (toAI a1) (toAI a2) boards rnd+ [arg1,arg2] -> + case do p1 <- lookupAI arg1 aiPlayers+ p2 <- lookupAI arg2 aiPlayers+ return (p1,p2)+ of Nothing -> ioError $ + userError $ "invalid AI: " ++ unwords [arg1, arg2]+ Just (p1,p2) ->+ do rnd <- getStdGen+ let (boards, rnd') = randomBoards numMatches rnd+ setStdGen rnd'+ playAIs p1 p2 boards rnd _ -> ioError $ userError $ usageInfo header options ++ footer- where ais = map fst aiPlayers --toAI :: String -> AI-toAI ai = maybe (error ("invalid ai: "++ai)) id (lookup ai aiPlayers)
src/Tests.hs view
@@ -4,12 +4,12 @@ -} module Tests where import Board -import AI.Tree+--import AI.Tree import AI.Eval import AI.Minimax import qualified Data.Map as Map import qualified Data.Set as Set-import List (delete, nub, sort)+import Data.List (delete, nub, sort) import Control.Monad (liftM) import Test.QuickCheck@@ -53,12 +53,13 @@ bs <- genStacks Black n ps <- genShuffle positions c <- arbitrary- m <- choose (1, n)+ --m <- choose (1, n) let whites = zip (take n ps) ws let blacks = zip (drop n ps) bs let pmap = Map.fromList (whites++blacks) return Board { active = c- , move = m+ , move = 0+ , moves = [] , pieces = pmap , activeCounts = countStacks c pmap , inactiveCounts = countStacks (invert c) pmap@@ -181,12 +182,11 @@ -- from valid moves from a starting board genTrace :: Board -> Gen [Board] genTrace b - | null moves = return [b]- | otherwise = do m <- elements moves- let b' = applyMove m b- bs <- genTrace b'+ | null ms = return [b]+ | otherwise = do m <- elements ms+ bs <- genTrace (applyMove m b) return (b:bs)- where moves = nextMoves b+ where ms = nextMoves b @@ -208,18 +208,18 @@ -- | upper and lower bounds for the evaluation function-prop_value_bounds :: Eval -> Trace -> Bool-prop_value_bounds eval (Trace bs)- = let vs = map eval bs in all (\v -> abs v<=infinity) vs-+--prop_value_bounds :: StaticEval -> Trace -> Bool+--prop_value_bounds f (Trace bs)+-- = let vs = map f bs in all (\v -> abs v<=infinity) vs +{- -- 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 = let bt = pruneDepth d $ mapTree eval1 $ boardTree b- in negamax_ab (-infinity) infinity bt == negamax bt+ in negamax_alpha_beta (minBound+1) maxBound bt == negamax bt -- correctness of alpha-beta minimax extended with principal variation@@ -227,12 +227,12 @@ prop_alpha_beta_pv :: Int -> Board -> Bool prop_alpha_beta_pv d b = let bt = pruneDepth d $ mapTree eval1 $ boardTree b- (v,ms)= negamaxPV bt+ PV v ms = undefined -- negamaxPV bt n = length ms b' = foldl (flip applyMove) b ms v' = eval1 b' in (-1)^n * v' == v-+-} {-@@ -299,13 +299,14 @@ , ("prop_inactive_counts", quickCheck prop_inactive_counts) , ("prop_active_heights", quickCheck prop_active_heights) , ("prop_inactive_heights", quickCheck prop_inactive_heights)+ --, ("prop_move_count", quickCheck prop_move_count) , ("prop_zoc_correct", quickCheck prop_zoc_correct) , ("prop_trace_alternating", quickCheck prop_trace_alternating) , ("prop_trace_ending", quickCheck prop_trace_ending)- , ("prop_value_bounds", quickCheck (prop_value_bounds eval1))- , ("prop_alpha_beta_pv 3", quickCheck (prop_alpha_beta_pv 3))- , ("prop_alpha_beta_pv 5", quickCheck (prop_alpha_beta_pv 5))- , ("prop_alpha_beta_pv 6", quickCheck (prop_alpha_beta_pv 6))+ --, ("prop_value_bounds", quickCheck (prop_value_bounds eval1))+ --, ("prop_alpha_beta_pv 3", quickCheck (prop_alpha_beta_pv 3))+ --, ("prop_alpha_beta_pv 5", quickCheck (prop_alpha_beta_pv 5))+ --, ("prop_alpha_beta_pv 6", quickCheck (prop_alpha_beta_pv 6)) ]
src/Tournament.hs view
@@ -2,7 +2,8 @@ module Tournament where import Board-import AI.Tree+import AI+import AI.Gametree import System.Random import Control.Monad @@ -11,11 +12,10 @@ -- result is 1 or -1 according to the winner playMatch :: Board -> StdGen -> AI -> AI -> IO Int playMatch b rnd p1 p2- | null branches = return (-1) -- p1 can't play, p2 wins+ | is_terminal b = return (-1) -- p1 can't play, p2 wins | otherwise = do putStrLn line liftM negate $ playMatch b' rnd' p2 p1- where bt@(GameTree _ branches) = boardTree b- (score, m, rnd') = strategy p1 bt rnd+ where (score, m, rnd') = playing p1 b rnd line = show (move b) ++ ". " ++ show (active b) ++ " ("++name p1 ++ "):\t" ++ " " ++ showMove m ++ "\tscore: " ++ show score