diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -1,3 +1,8 @@ +hstzaar 0.8.2 31/10/2011 +- tweaked the AI evaluation function; should play better now +- AI level 1 is now default +- added option to not draw piece stacks + hstzaar 0.8.1 10/08/2011 - added "about this program" dialog diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -1,5 +1,5 @@ name: hstzaar -version: 0.8.1 +version: 0.8.2 category: Game diff --git a/hstzaar.glade b/hstzaar.glade --- a/hstzaar.glade +++ b/hstzaar.glade @@ -117,6 +117,14 @@ + + True + Draw stacks + True + True + + + True Show heights diff --git a/src/AI.hs b/src/AI.hs --- a/src/AI.hs +++ b/src/AI.hs @@ -5,22 +5,32 @@ import AI.Utils import AI.Minimax import AI.Eval - +-- import Debug.Trace --- all AI players; default AI is the first one +-- all AI players; ply depth >1 do not necessarily play better! aiPlayers :: [(String,AI)] -aiPlayers = [("level0",level0), ("level1",level1), ("level2",level2)] +aiPlayers = ("level0",basic) : [("level"++show n, ply n) | n<-[1,2,3]] -level0 = AI { name = "Level 0" - , description = "Minimax alpha-beta depth 2 (eval0)" - , strategy = minimaxStrategy 2 eval0 - } +-- basic AI: material evaluation, depth 1 +basic = AI { name = "Level 0" + , description = "Minimax alpha-beta depth 2 (eval0)" + , strategy = negamaxStrategy 2 eval0 + } -level1 = AI { name = "Level 1" - , description = "Minimaxing alpha-beta depth 2 (eval1)" - , strategy = minimaxStrategy 2 eval1 - } +-- better AI, parameterized by ply depth +ply :: Int -> AI +ply d = AI { name = "Level " ++ show d + , description = + "Minimaxing alpha-beta depth " ++ show (2*d) ++ " (eval1)" + , strategy = withStacks $ \n -> + -- increase depth inversely linear with number of stacks + let d' = roundup (((60-n)*2*d)`div`60 + 1) + in negamaxStrategy d' eval1 + } + where roundup n = max 2 n -- + n`mod`2 + +{- level2 = AI { name = "Level 2" , description = "Minimaxing alpha-beta depth 2-4 (eval1)" , strategy = (withNPieces $ \numpieces -> @@ -30,4 +40,4 @@ minimaxStrategy 2 eval1 ) } - +-} diff --git a/src/AI/Eval.hs b/src/AI/Eval.hs --- a/src/AI/Eval.hs +++ b/src/AI/Eval.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} -- Static evaluation functions for board positions -module AI.Eval( eval0, eval1 +module AI.Eval( eval0, + eval1 ) where import Board @@ -20,35 +21,35 @@ counts = countStacks (active b) counts'= countStacks (inactive b) - -- capture moves for each player + -- capture moves for active player captures = nextCaptureMoves b - --captures'= nextCaptureMoves (swapBoard b) + -- captures'= nextCaptureMoves (swapBoard b) -- stack heights by piece kinds heights = sumHeights (active b) heights'= sumHeights (inactive b) -- material score - material = sum [(mw*h)`div`(c+1) | (c,h)<-zip counts heights] - - sum [(mw*h)`div`(c+1) | (c,h)<-zip counts' heights'] + material = sum [(mw*h)`div`c | (c,h)<-zip counts heights] - + sum [(mw*h)`div`c | (c,h)<-zip counts' heights'] -- scoreing weights coeficients mw = 100 -- material --- | Level 1: material, positional and threats +-- | Level >=1: material + positional eval1 :: Board -> Int eval1 b | any (==0) counts || (move b==1 && null captures) = -infinity - | any (==0) counts' = infinity - | otherwise = material + positional + threats + | any (==0) counts' || not (null threats) = infinity + | otherwise = material + positional where -- count stacks by piece kind for each player counts = countStacks (active b) counts'= countStacks (inactive b) - -- capture moves for each player + -- capture moves for active player captures = nextCaptureMoves b --captures'= nextCaptureMoves (swapBoard b) @@ -57,23 +58,22 @@ heights'= sumHeights (inactive b) -- material score - material = sum [(mw*h)`div`(c+1) | (c,h)<-zip counts heights] - - sum [(mw*h)`div`(c+1) | (c,h)<-zip counts' heights'] - - zoc = zoneOfControl b -- zone of control for the active player - zoc_heights = sumHeights zoc -- piece types in the zone of control + material = sum [(mw*h)`div`c | (c,h)<-zip counts heights] - + sum [(mw*h)`div`c | (c,h)<-zip counts' heights'] - -- positional score - positional = sum [(pw*h)`div`(c+1) | (c,h)<-zip counts' zoc_heights] - - -- immediate threats to opponent pieces + -- zone of control of the active player + zoc = zoneOfControl b + -- positional score + zoc_heights = sumHeights zoc zoc_counts = countStacks zoc - threats = sum [tw | (x,y)<-zip counts' zoc_counts, x<=min 2 y] + positional = sum [(pw*h)`div`c | (c,h)<-zip counts' zoc_heights] + + -- immediate threats to opponent's pieces + threats = [undefined | (x,y)<-zip counts' zoc_counts, move b+x<=3 && x==y] -- scoreing weights coeficients - mw = 100 -- material - pw = 50 -- positional - tw = 1000 -- threats + mw = 100 -- material weight + pw = 100 -- positional weight diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs --- a/src/AI/Minimax.hs +++ b/src/AI/Minimax.hs @@ -1,53 +1,56 @@ +{-# LANGUAGE BangPatterns #-} module AI.Minimax( EvalFunc - , minimaxStrategy - , minimax - , minimax_ab - , minimaxPV + , negamaxStrategy + , negamax + , negamax_ab + , negamaxPV ) where import AI.Utils import Board +-- import Debug.Trace -- | type of static evaluation functions type EvalFunc = Board -> Int --- | Minimax with alpha-beta and static depth prunning -minimaxStrategy :: Int -> EvalFunc -> Strategy -minimaxStrategy n eval bt rndgen - | isEmptyTree bt = error "minimaxStrategy: empty tree" -minimaxStrategy n eval bt rndgen = ((m1,m2), rndgen) - where (bestscore, m1:m2:_) = minimaxPV bt' +-- | Negamax with alpha-beta and static depth prunning +negamaxStrategy :: Int -> EvalFunc -> Strategy +negamaxStrategy n evf bt rndgen + | isEmptyTree bt = error "negamaxStrategy: empty tree" +negamaxStrategy n evf bt rndgen + = ((m1,m2), rndgen) + where (bestscore, m1:m2:_) = negamaxPV bt' bt' = pruneDepth n $ -- ^ prune to depth `n' - mapTree eval bt -- ^ apply static evaluation function + mapTree evf bt -- ^ apply static evaluation function --- | Naive minimax algorithm (not used) +-- | Naive negamax algorithm (not used) -- | nodes values are static evaluation scores -minimax :: (Num a, Ord a) => GameTree a m -> a -minimax = minimax' 0 +negamax :: (Num a, Ord a) => GameTree a m -> a +negamax = negamax' 0 -minimax' :: (Num a, Ord a) => Int -> GameTree a m -> a -minimax' depth (GameTree x []) = x -minimax' depth (GameTree _ branches) +negamax' :: (Num a, Ord a) => Int -> GameTree a m -> a +negamax' depth (GameTree x []) = x +negamax' depth (GameTree _ branches) | odd depth = - minimum vs | otherwise = maximum vs - where vs = map (minimax' (1+depth) . snd) branches + where vs = map (negamax' (1+depth) . snd) branches --- | Minimax with alpha-beta prunning -minimax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a -minimax_ab = minimax_ab' 0 +-- | Negamax with alpha-beta prunning +negamax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a +negamax_ab = negamax_ab' 0 -minimax_ab' :: (Num a, Ord a) => Int -> a -> a -> GameTree a m -> a -minimax_ab' depth a b (GameTree x []) = a `max` x `min` b -minimax_ab' depth a b (GameTree _ branches) = cmx a b (map snd branches) +negamax_ab' :: (Num a, Ord a) => Int -> a -> a -> GameTree a m -> a +negamax_ab' depth a b (GameTree x []) = a `max` x `min` b +negamax_ab' depth 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' | odd depth = -minimax_ab' (1+depth) (-b) (-a) t - | otherwise = minimax_ab' (1+depth) a b t + where a' | odd depth = -negamax_ab' (1+depth) (-b) (-a) t + | otherwise = negamax_ab' (1+depth) a b t -- | Principal Variantions data PV = PV !Int [Move] deriving (Show) @@ -58,26 +61,40 @@ instance Ord PV where compare (PV x _) (PV y _) = compare x y +instance Num PV where + (+) = undefined + (-) = undefined + (*) = undefined + fromInteger = undefined + signum = undefined + abs = undefined + negate (PV x ms) = PV (-x) ms + +{- negatePV :: PV -> PV negatePV (PV x ms) = PV (-x) ms - +-} --- | Minimax with alpha-beta pruning +-- | Negamax with alpha-beta pruning -- | extended with score and principal variation -minimaxPV :: GameTree Int Move -> (Int, [Move]) -minimaxPV bt - = case minimaxPV_ab' 0 [] (PV (-infinity-1) []) (PV (infinity+1) []) bt of - PV v ms -> (v,ms) +negamaxPV :: GameTree Int Move -> (Int, [Move]) +negamaxPV bt + = case negamaxPV_ab 0 [] lo hi bt of + PV v ms -> (v, reverse ms) + where lo = PV (-maxBound) [] + hi = PV maxBound [] --- | first parameter determines if we negate children scores --- | minimaxPV_ab' :: (Num a, Ord a) => Int -> [m] -> a -> a -> GameTree a m -> (a, [m]) -minimaxPV_ab' depth ms a b (GameTree x []) = a `max` PV x (reverse ms) `min` b -minimaxPV_ab' depth ms a b (GameTree _ branches) = cmx a b branches - where cmx a b [] = a - cmx a b ((m,t) : branches) - | a'==b = a' - | otherwise = cmx a' b branches - where a'| odd depth = negatePV $ minimaxPV_ab' (1+depth) (m:ms) (negatePV b) (negatePV a) t - | otherwise = minimaxPV_ab' (1+depth) (m:ms) a b t +-- | depth parameter determines if we negate children scores +-- | negamaxPV_ab :: (Num a, Ord a) => Int -> [m] -> a -> a -> GameTree a m -> (a, [m]) +negamaxPV_ab depth ms a b (GameTree x []) = a `max` PV x ms `min` b +negamaxPV_ab depth ms a b (GameTree _ branches) = cmx a b branches + where + cmx a b [] = a + cmx a b ((m,t) : branches) + | a'>=b = a' + | otherwise = cmx a' b branches + where a' = if odd depth + then - negamaxPV_ab (1+depth) (m:ms) (-b) (-a) t + else negamaxPV_ab (1+depth) (m:ms) a b t diff --git a/src/AI/Utils.hs b/src/AI/Utils.hs --- a/src/AI/Utils.hs +++ b/src/AI/Utils.hs @@ -3,7 +3,7 @@ ( winOrPreventLoss , pruneDepth, pruneBreadth , highFirst, lowFirst - , withNPieces, withBoard + , withStacks, withBoard , dontPass, singleCaptures , zoneOfControl ) where @@ -45,8 +45,9 @@ withBoard :: (Board -> Strategy) -> Strategy withBoard f t@(GameTree b _) g = f b t g -withNPieces :: (Int -> Strategy) -> Strategy -withNPieces f = withBoard $ \b -> f (IntMap.size (active b) + IntMap.size (inactive b)) +-- number of stacks of both players +withStacks :: (Int -> Strategy) -> Strategy +withStacks f = withBoard $ \b -> f (IntMap.size (active b) + IntMap.size (inactive b)) @@ -107,7 +108,7 @@ where you = active board other = inactive board - who = player board + who = playerColor board -- white pieces that can make at least one capture captures = IntMap.filterWithKey forPiece2 you diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -32,7 +32,7 @@ , mapTree' , isEmptyTree , endGame - , whiteWins + , winnerColor --, swapBoard --, swapBoardTree , nextCaptureMoves @@ -65,8 +65,8 @@ -- | The board state -- | current turn, active player pieces, other player pieces data Board - = Board { player :: !Bool, -- next to play (True=White, False=Black) - move :: !Int, -- first or second move in a turn + = Board { playerColor :: !Bool, -- next to play (True=White, False=Black) + move :: !Int, -- first or second move of a turn active :: HalfBoard, -- active player's pieces inactive :: HalfBoard -- inactive player's pieces } deriving (Eq, Show, Read) @@ -118,7 +118,7 @@ -- | A game tree with nodes s and moves m -data GameTree s m = GameTree !s [(m, GameTree s m)] +data GameTree s m = GameTree s [(m, GameTree s m)] deriving Show -- | auxiliary functions over game trees @@ -168,11 +168,11 @@ -- | Projections to get the white & black half-boards whites, blacks :: Board -> HalfBoard -whites board | player board = active board - | otherwise = inactive board +whites board | playerColor board = active board + | otherwise = inactive board -blacks board | player board = inactive board - | otherwise = active board +blacks board | playerColor board = inactive board + | otherwise = active board -- | board size (number of pieces) @@ -203,7 +203,7 @@ nextMoves board = case move board of 1 -> nextCaptureMoves board - 2 -> nextStackingMoves board ++ nextCaptureMoves board ++ [Pass] + 2 -> nextCaptureMoves board ++ nextStackingMoves board ++ [Pass] _ -> error "nextMoves: invalid board" @@ -213,7 +213,7 @@ nextCaptureMoves board = IntMap.foldWithKey forPiece [] you where you = active board - who = player board + who = playerColor board forPiece :: Position -> Piece -> [Move] -> [Move] forPiece !p (_, !i) moves = foldl' downLine moves (sixLines p) where @@ -246,7 +246,7 @@ nextStackingMoves :: Board -> [Move] nextStackingMoves board = foldl' forPiece [] (IntMap.keys you) where - who = player board + who = playerColor board you = active board (tzaars:tzarras:totts: _) = countStacks you forPiece :: [Move] -> Position -> [Move] @@ -379,11 +379,12 @@ nullCaptures = null (nextCaptureMoves b) -- | Determine the game winner; assumes endGame is True -whiteWins :: Board -> Bool -whiteWins b = case move b of - 1 -> not (player b) - 2 -> player b - _ -> error "whiteWins: invalid board" +winnerColor :: Board -> Bool +winnerColor b + = case move b of + 1 -> not (playerColor b) + 2 -> playerColor b + _ -> error "winnerColor: invalid board" @@ -396,7 +397,7 @@ do { piece<-IntMap.lookup pos other ; return (not who,piece) } - where who = player board + where who = playerColor board you = active board other = inactive board @@ -526,7 +527,7 @@ -- 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)] ++ @@ -544,36 +545,44 @@ -- a generator for boards -- size argument is a bound for the total number of pieces -genBoard :: Int -> Gen Board -genBoard n = do ws <- genPieces n' - bs <- genPieces n' - positions' <- genShuffle positions - who <- arbitrary - let whites = zip (take n' positions') ws - let blacks = zip (drop n' positions') bs - return $ Board who 1 (IntMap.fromList whites) (IntMap.fromList blacks) - where n' = (min 60 n)`div`2 - - - +genBoard :: Int -> Gen Board +genBoard n + = do ws <- genPieces n' + bs <- genPieces n' + ps <- genShuffle positions + who <- arbitrary + let whites = zip (take n' ps) ws + let blacks = zip (drop n' ps) bs + return $ Board who 1 (IntMap.fromList whites) (IntMap.fromList blacks) + where n' = min 30 (n`div`2) + + +-- generate pieces genPieces :: Int -> Gen [(Type,Int)] genPieces n = do pieces <- genShuffle allpieces - k <- choose (0,n) - genStacks k (take n pieces) - where allpieces = [(t,1) | t<-replicate 6 Tzaar ++ - replicate 9 Tzarra ++ - replicate 15 Tott] + k <- choose (1, n) -- number of stacking moves + hs <- genStacks k (replicate 30 1) + return $ take n $ zip pieces hs + where allpieces = replicate 6 Tzaar ++ + replicate 9 Tzarra ++ + replicate 15 Tott +-- same as above but ensures at least one piece of each kind (unused) +genPieces' n = do ps <- genPieces n + return ((Tzaar,1):(Tzarra,1):(Tott,1):ps) --- generate stacks from single pieces -genStacks 0 xs = return xs -genStacks _ [] = return [] -genStacks _ [x]= return [x] -genStacks (n+1) xs = do p1@(t1,h1) <- elements xs - let xs' = delete p1 xs - p2@(t2,h2) <- elements xs' - genStacks n ((t1,h1+h2) : delete p2 xs') - + +-- generate stack heights +genStacks 0 xs = return xs +genStacks _ [] = return [] +genStacks _ [x] = return [x] +genStacks n xs = do h1 <- elements xs + let xs' = delete h1 xs + h2 <- elements xs' + genStacks (n-1) ((h1+h2) : delete h2 xs') + + + -- auxiliary function to shuffle a list genShuffle :: Eq a => [a] -> Gen [a] diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -25,9 +25,11 @@ import Board import AI +{- -- | Piece colors data PieceColor = White | Black deriving (Eq,Show,Read) +-} -- | Record to hold the current game state data Game = Game @@ -76,6 +78,7 @@ menu_item_undo :: MenuItem, menu_item_redo :: MenuItem, menu_item_pass :: MenuItem, + menu_item_draw_stacks :: CheckMenuItem, menu_item_show_heights :: CheckMenuItem, menu_item_show_moves :: CheckMenuItem, menu_item_random_start :: CheckMenuItem, @@ -124,6 +127,7 @@ mun<- xmlGetWidget xml castToMenuItem "menu_item_undo" mre<- xmlGetWidget xml castToMenuItem "menu_item_redo" mpa<- xmlGetWidget xml castToMenuItem "menu_item_pass" + mds<- xmlGetWidget xml castToCheckMenuItem "menu_item_draw_stacks" msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights" msm<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_moves" mrs<- xmlGetWidget xml castToCheckMenuItem "menu_item_random_start" @@ -135,10 +139,12 @@ m<- xmlGetWidget xml castToMenu "menu_ai" r <- radioMenuItemNewWithLabel (name $ snd $ head aiPlayers) menuAttach m r 0 1 0 1 - rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t) - menuAttach m w 0 1 i (i+1) - return w - | (t,i)<-zip (tail aiPlayers) [1..]] + rs@(r1:_) <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t) + menuAttach m w 0 1 i (i+1) + return w + | (t,i)<-zip (tail aiPlayers) [1..]] + -- select default AI + checkMenuItemSetActive r1 True -- open/save file dialogs ff <- fileFilterNew fileFilterSetName ff "Tzaar saved games (*.tza)" @@ -151,7 +157,7 @@ fileChooserAddFilter svf ff cid <- statusbarGetContextId sb "status" widgetShowAll mw - return (GUI mw bd abd sb pb mn mo ms mq mun mre mpa + return (GUI mw bd abd sb pb mn mo ms mq mun mre mpa mds msh msm mrs (zip (r:rs) (map snd aiPlayers)) mab opf svf cid) @@ -191,6 +197,7 @@ onActivateLeaf (menu_item_pass gui) (movePass gui gameRef) + onActivateLeaf (menu_item_draw_stacks gui) $ redrawCanvas (canvas gui) onActivateLeaf (menu_item_show_heights gui) $ redrawCanvas (canvas gui) onActivateLeaf (menu_item_show_moves gui) $ redrawCanvas (canvas gui) @@ -262,9 +269,9 @@ } where b = board g s = state g - color = if player b then "White" else "Black" + color = if playerColor b then "White" else "Black" msg = case s of - Finish -> if whiteWins b then "White wins" else "Black wins" + Finish -> if winnerColor b then "White wins" else "Black wins" Wait2 -> "Thinking..." -- 2 moves per turn after the 1st move _ -> concat [color, " (turn ", show (1+History.position h`div`2), @@ -367,9 +374,9 @@ makeMove m g = Game { board=b', trail=m:trail g, state=state' } where b' = applyMove (board g) m - state' | endGame b' = Finish -- game ended - | player b' = Wait0 -- human to play - | otherwise = Wait2 -- opponent to play + state' | endGame b' = Finish -- game ended + | playerColor b' = Wait0 -- human to play + | otherwise = Wait2 -- opponent to play --------------------------------------------------------------------------------- @@ -387,20 +394,21 @@ drawCanvas gui gameRef = do b1 <- checkMenuItemGetActive (menu_item_show_heights gui) b2 <- checkMenuItemGetActive (menu_item_show_moves gui) + b3 <- checkMenuItemGetActive (menu_item_draw_stacks gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui) (g,_) <- Var.get gameRef renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp -> - do renderWith tmp (setTransform w h >> renderBoard b1 b2 g) + do renderWith tmp (setTransform w h >> renderBoard b1 b2 b3 g) setSourceSurface tmp 0 0 paint -- render the board and pieces -renderBoard :: Bool -> Bool -> Game -> Render () -renderBoard showheights showmoves g +renderBoard :: Bool -> Bool -> Bool -> Game -> Render () +renderBoard showheights showmoves showstacks g = do -- paint the background boardBg >> paint -- paint the playing area light gray @@ -413,18 +421,18 @@ renderGrid -- draw the pieces & highlight selection case state g of - Start0 -> pieces showheights b + Start0 -> pieces showheights showstacks b Start1 p -> do highlight p - pieces showheights b + pieces showheights showstacks b when showmoves $ mapM_ renderMove (targets p) - Wait0 -> do pieces showheights b + Wait0 -> do pieces showheights showstacks b when showmoves $ mapM_ renderMove (trail g) Wait1 p -> do highlight p - pieces showheights b + pieces showheights showstacks b when showmoves $ mapM_ renderMove (targets p) - Wait2 -> do pieces showheights b + Wait2 -> do pieces showheights showstacks b when showmoves $ mapM_ renderMove (trail g) - Finish -> do pieces showheights b + Finish -> do pieces showheights showstacks b when showmoves $ mapM_ renderMove (trail g) where b = board g moves = nextMoves b @@ -523,20 +531,20 @@ -- render all pieces in the board -pieces :: Bool -> Board -> Render () -pieces showheights board +pieces :: Bool -> Bool -> Board -> Render () +pieces showheights showstacks board = do setLineWidth 2 - mapM_ (piece showheights) ps + mapM_ (piece showheights showstacks) ps -- sort pieces by reverse position to draw from back to front where ps = sortBy cmp $ - zip (repeat White) (IntMap.assocs (whites board)) ++ - zip (repeat Black) (IntMap.assocs (blacks board)) + zip (repeat whiteColors) (IntMap.assocs (whites board)) ++ + zip (repeat blackColors) (IntMap.assocs (blacks board)) cmp (_,(x,_)) (_,(y,_)) = compare y x -piece :: Bool -> (PieceColor,(Position,Piece))-> Render () -piece showheight (c,(p,(t,size))) - = do y<-stack size yc +piece :: Bool -> Bool -> (PieceColors,(Position,Piece))-> Render () +piece showheight showstacks (cs,(p,(t,size))) + = do y<-stack size' yc when (showheight && size>1) $ -- show the height? do selectFontFace "sans-serif" FontSlantNormal FontWeightBold setFontSize 50 @@ -545,8 +553,9 @@ setSourceRGB 1 0 0 showCenteredText xc y label where label = show size + size' = if showstacks then size else 1 (xc,yc)= screenCoordinate p - (chipColor, lineColor, crownColor) = pieceColors c + (chipColor, lineColor, crownColor) = cs stack 0 y = case t of Tott -> return y Tzarra -> crownColor >> disc 0.4 xc y >> @@ -578,6 +587,7 @@ -- (chip color, line color, crown color) +{- pieceColors :: PieceColor -> (Render (), Render (), Render ()) pieceColors White = (setSourceRGB 1 1 1, setSourceRGB 0 0 0, @@ -585,7 +595,17 @@ pieceColors Black = (setSourceRGB 0 0 0, setSourceRGB 1 1 1, setSourceRGB 0.75 0.75 0.75) +-} +type PieceColors = (Render (), Render (), Render ()) + +blackColors, whiteColors :: PieceColors +blackColors = (setSourceRGB 0 0 0, + setSourceRGB 1 1 1, + setSourceRGB 0.75 0.75 0.75) +whiteColors = (setSourceRGB 1 1 1, + setSourceRGB 0 0 0, + setSourceRGB 0.35 0.25 0) diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -50,7 +50,7 @@ where value = eval1 board --- end game positions give plus/minus infinityinity scores +-- end game positions give plus/minus infinity scores prop_inactive_lost :: Board -> Property prop_inactive_lost b = not (active_lost b) && inactive_lost b ==> eval1 b == infinity @@ -64,25 +64,24 @@ -- parameters: number of pieces, pruning depth prop_alpha_beta :: Int -> Int -> Property prop_alpha_beta npieces depth - = forAllShrink (resize npieces arbitrary) shrink $ \b -> - admissible b ==> + = forAllShrink (resize npieces arbitrary) shrink $ + \b -> admissible b ==> let bt = mkTree depth eval1 b - in minimax_ab (-infinity) infinity bt == minimax bt + in negamax_ab (-infinity) infinity bt == negamax bt -- correctness of alpha-beta minimax extended with principal variation -- parameters: number of pieces, pruning depth prop_alpha_beta_pv :: Int -> Int -> Property prop_alpha_beta_pv npieces depth - | depth`mod`4 == 0 - = forAllShrink (resize npieces arbitrary) shrink $ \b -> - admissible b ==> + = forAllShrink (resize npieces arbitrary) shrink $ + \b -> admissible b ==> let bt = mkTree depth eval1 b - (v,ms)= minimaxPV bt + (v,ms)= negamaxPV bt (GameTree v' _) = foldl treeMove bt ms in neg (length ms) v'==v - where neg n x | n`mod`4==0 = x - | n`mod`4==2 = -x + where neg n x | n`mod`4==0 = x + | n`mod`4==2 = -x mkTree :: Int -> EvalFunc -> Board -> GameTree Int Move @@ -142,12 +141,14 @@ --, ("prop_zoc_correct2", quickCheck prop_zoc_correct2) , ("prop_alpha_beta 10 4", quickCheck (prop_alpha_beta 10 4)) - , ("prop_alpha_beta 15 6", - quickCheck (prop_alpha_beta 15 6)) + , ("prop_alpha_beta 10 6", + quickCheck (prop_alpha_beta 10 6)) , ("prop_alpha_beta_pv 10 4", quickCheck (prop_alpha_beta_pv 10 4)) , ("prop_alpha_beta_pv 15 6", quickCheck (prop_alpha_beta_pv 15 6)) + , ("prop_alpha_beta_pv 20 4", + quickCheck (prop_alpha_beta_pv 20 4)) ]