hstzaar 0.8.1 → 0.8.2
raw patch · 10 files changed
+236/−165 lines, 10 files
Files
- RELEASE-NOTES +5/−0
- hstzaar.cabal +1/−1
- hstzaar.glade +8/−0
- src/AI.hs +22/−12
- src/AI/Eval.hs +22/−22
- src/AI/Minimax.hs +59/−42
- src/AI/Utils.hs +5/−4
- src/Board.hs +53/−44
- src/GUI.hs +48/−28
- src/Tests.hs +13/−12
RELEASE-NOTES view
@@ -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
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.8.1+version: 0.8.2 category: Game
hstzaar.glade view
@@ -117,6 +117,14 @@ </widget> </child> <child>+ <widget class="GtkCheckMenuItem" id="menu_item_draw_stacks">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Draw stacks</property>+ <property name="use_underline">True</property>+ <property name="active">True</property>+ </widget>+ </child>+ <child> <widget class="GtkCheckMenuItem" id="menu_item_show_heights"> <property name="visible">True</property> <property name="label" translatable="yes">Show heights</property>
src/AI.hs view
@@ -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 ) }-+-}
src/AI/Eval.hs view
@@ -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
src/AI/Minimax.hs view
@@ -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
src/AI/Utils.hs view
@@ -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
src/Board.hs view
@@ -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]
src/GUI.hs view
@@ -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)
src/Tests.hs view
@@ -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)) ]