diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -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) diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -1,5 +1,5 @@ name: hstzaar -version: 0.9.1 +version: 0.9.2 category: Game @@ -13,7 +13,7 @@ by Tom Hawkins . author: Pedro Vasconcelos -maintainer: Pedro Vasconcelos +maintainer: Pedro Vasconcelos 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 diff --git a/src/AI.hs b/src/AI.hs --- a/src/AI.hs +++ b/src/AI.hs @@ -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 diff --git a/src/AI/Eval.hs b/src/AI/Eval.hs --- a/src/AI/Eval.hs +++ b/src/AI/Eval.hs @@ -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 diff --git a/src/AI/Gametree.hs b/src/AI/Gametree.hs new file mode 100644 --- /dev/null +++ b/src/AI/Gametree.hs @@ -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 + + diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs --- a/src/AI/Minimax.hs +++ b/src/AI/Minimax.hs @@ -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 - diff --git a/src/AI/Tree.hs b/src/AI/Tree.hs deleted file mode 100644 --- a/src/AI/Tree.hs +++ /dev/null @@ -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] --} - - - - - - diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -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, diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -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)) ] diff --git a/src/Tournament.hs b/src/Tournament.hs --- a/src/Tournament.hs +++ b/src/Tournament.hs @@ -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