hstzaar 0.6 → 0.7
raw patch · 16 files changed
+594/−512 lines, 16 filesdep +filepath
Dependencies added: filepath
Files
- RELEASE-NOTES +10/−0
- data/hstzaar.glade +4/−10
- hstzaar.cabal +3/−2
- src/AI.hs +10/−10
- src/AI/Eval.hs +36/−53
- src/AI/Lame.hs +0/−33
- src/AI/Minimax.hs +20/−39
- src/AI/Utils.hs +61/−24
- src/Board.hs +55/−31
- src/GUI.hs +262/−240
- src/History.hs +67/−0
- src/Main.hs +10/−12
- src/StateVar.hs +0/−49
- src/Tests.hs +7/−7
- src/Tournament.hs +0/−2
- src/Var.hs +49/−0
RELEASE-NOTES view
@@ -1,3 +1,13 @@+hstzaar 0.7 17/06/2011+- improved AI: + level 0 does material evaluation only+ levels >1 does material, positional and threats+ level 2 searches deeper after mid-game+- removed random AI (AI/Lame.hs)+- implemented save & open games+- restructured GUI code: + undo/redo history handling is now a separate module+ hstzaar 0.6 04/05/2011 - improved AI by spliting turns into 2 game tree levels - reduced heap memory residency
data/hstzaar.glade view
@@ -1,6 +1,6 @@ <?xml version="1.0" encoding="UTF-8"?> <glade-interface>- <!-- interface-requires gtk+ 2.6 -->+ <!-- interface-requires gtk+ 2.16 --> <!-- interface-naming-policy toplevel-contextual --> <widget class="GtkWindow" id="mainwindow"> <property name="title" translatable="yes">HsTZAAR</property>@@ -45,14 +45,6 @@ </widget> </child> <child>- <widget class="GtkImageMenuItem" id="menu_item_save_as">- <property name="label">gtk-save-as</property>- <property name="visible">True</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- </widget>- </child>- <child> <widget class="GtkSeparatorMenuItem" id="separatormenuitem1"> <property name="visible">True</property> </widget>@@ -129,13 +121,15 @@ <property name="visible">True</property> <property name="label" translatable="yes">Show heights</property> <property name="use_underline">True</property>+ <property name="active">True</property> </widget> </child> <child> <widget class="GtkCheckMenuItem" id="menu_item_show_moves"> <property name="visible">True</property>- <property name="label" translatable="yes">Show available moves</property>+ <property name="label" translatable="yes">Show moves</property> <property name="use_underline">True</property>+ <property name="active">True</property> </widget> </child> <child>
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.6+version: 0.7 category: Game @@ -30,10 +30,11 @@ executable hstzaar hs-source-dirs: src main-is: Main.hs- other-modules: GUI StateVar Board AI AI.Utils AI.Lame AI.Eval AI.Minimax Tournament Tests+ other-modules: GUI Var History Board AI AI.Utils AI.Eval AI.Minimax Tournament Tests build-depends: base >= 4 && < 5, haskell98,+ filepath >= 1.1, containers, gtk >=0.11, cairo >= 0.11,
src/AI.hs view
@@ -3,31 +3,31 @@ import Board import AI.Utils-import AI.Lame import AI.Minimax+import AI.Eval -- all AI players; default AI is the first one -aiPlayers :: [AI]-aiPlayers = [level0, level1, level2]+aiPlayers :: [(String,AI)]+aiPlayers = [("level0",level0), ("level1",level1), ("level2",level2)] level0 = AI { name = "Level 0"- , description = "Randomly selects the next turn."- , strategy = lameStrategy+ , description = "Minimax alpha-beta depth 2 (eval0)"+ , strategy = minimaxStrategy 2 eval0 } level1 = AI { name = "Level 1"- , description = "Minimaxing alpha-beta depth 2"- , strategy = minimaxStrategy 2+ , description = "Minimaxing alpha-beta depth 2 (eval1)"+ , strategy = minimaxStrategy 2 eval1 } level2 = AI { name = "Level 2"- , description = "Minimaxing alpha-beta depth 2-4"+ , description = "Minimaxing alpha-beta depth 2-4 (eval1)" , strategy = (withNPieces $ \numpieces -> if numpieces>30 then- minimaxStrategy 4+ minimaxStrategy 4 eval1 else- minimaxStrategy 2+ minimaxStrategy 2 eval1 ) }
src/AI/Eval.hs view
@@ -1,27 +1,53 @@ {-# LANGUAGE BangPatterns #-}--- Static evaluation functions of board positions-module AI.Eval( eval- , zoneOfControl+-- Static evaluation functions for board positions+module AI.Eval( eval0, eval1 ) where import Board+import AI.Utils (zoneOfControl) import qualified Data.IntMap as IntMap-import Debug.Trace + -- | Static evaluation of a position for the active player-eval :: Board -> Int-eval b+-- | Level 0: material only+eval0 :: Board -> Int+eval0 b | any (==0) counts || (move b==1 && null captures) = -infinity | any (==0) counts' = infinity- | otherwise = {- trace (unwords ["material=", show material,- "position=", show positional,- "threats=", show threats]) $ -}- material + positional + threats+ | otherwise = material where -- count stacks by piece kind for each player counts = countStacks (active b) counts'= countStacks (inactive b)++ -- capture moves for each player+ captures = nextCaptureMoves 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'] ++ -- scoreing weights coeficients+ mw = 100 -- material + +++-- | Level 1: material, positional and threats+eval1 :: Board -> Int+eval1 b+ | any (==0) counts || (move b==1 && null captures) = -infinity+ | any (==0) counts' = infinity+ | otherwise = material + positional + threats+ where+ -- count stacks by piece kind for each player + counts = countStacks (active b)+ counts'= countStacks (inactive b)+ -- capture moves for each player captures = nextCaptureMoves b --captures'= nextCaptureMoves (swapBoard b) @@ -60,49 +86,6 @@ sum !x !y !z ((Tzarra,h):ps) = sum x (y+h) z ps sum !x !y !z ((Tott,h):ps) = sum x y (z+h) ps sum !x !y !z [] = [x,y,z]------ Estimate the zone of control of the active player--- i.e., the set of opponent pieces reachable in a turn (two capture moves)-zoneOfControl :: Board -> HalfBoard-zoneOfControl board- = IntMap.filterWithKey forPiece1 other- where- you = active board- other = inactive board- who = player board- -- white pieces that can make at least one capture- captures = IntMap.filterWithKey forPiece2 you-- forPiece1, forPiece2 :: Position -> Piece -> Bool- forPiece1 p (_, i) = or $ map (downLine0 i) $ sixLines p- forPiece2 p (_, h) = or $ map (downLine2 h) $ sixLines p-- downLine0, downLine1, downLine2 :: Int -> [Position] -> Bool-- downLine0 i [] = False- downLine0 i (p:ps) - = case atPosition board p of- Nothing -> downLine0 i ps- Just (who', (_, h)) | who'==who -> - h>=i || (p`IntMap.member`captures && downLine1 i ps)- Just (_, (_, j)) -> - or $ map (downLine1 (max i j)) $ sixLines p-- downLine1 i [] = False- downLine1 i (p:ps) - = case atPosition board p of- Nothing -> downLine1 i ps- Just (who', (_, h)) | who'==who -> h>=i- _ -> False-- downLine2 h [] = False- downLine2 h (p:ps) - = case atPosition board p of- Nothing -> downLine2 h ps- Just (who', (_, i)) | who'/=who -> h>=i- _ -> False
− src/AI/Lame.hs
@@ -1,33 +0,0 @@--- | An example AI player.-module AI.Lame(lameStrategy) where--import System.Random-import AI.Utils-import Board---- randomly selects the next valid turn-lameStrategy :: Strategy-lameStrategy = withNPieces $ - \n -> if n==60 then lame0 else lameNext ---- | Starting move: capture only-lame0 :: Strategy-lame0 (GameTree _ branches) rnd = (turns !! i, rnd')- where- turns = [ (m1, Pass) | (m1, _) <- branches ]- (i, rnd') = randomR (0, length turns - 1) rnd----- | The lame strategy picks a valid turn at random. --- If a two-move turn is available, it picks one. (wow, pretty smart!)-lameNext :: Strategy-lameNext (GameTree _ branches) rnd = (turns !! i, rnd')- where- allTurns = [ (m1,m2) | - (m1,GameTree _ branches')<-branches, - (m2, _) <- branches']- goodTurns = [ (m1, m2) | (m1, m2) <- allTurns, m2/=Pass ]- turns = if null goodTurns then allTurns else goodTurns- (i, rnd') = randomR (0, length turns - 1) rnd--
src/AI/Minimax.hs view
@@ -1,51 +1,29 @@-module AI.Minimax( minimaxStrategy+module AI.Minimax( EvalFunc+ , minimaxStrategy , minimax , minimax_ab , minimaxPV ) where ---import Data.List (sort, sortBy, maximumBy, minimumBy) import AI.Utils-import AI.Eval import Board -{---- | Minimaxing AI player with fixed depth -fixed_ply :: Int -> AI-fixed_ply depth- = AI { name = "ply_" ++ show depth - , description = "Minimaxing with limit depth " ++ show depth - , strategy = minimaxStrategy depth- }- ---- dynamic strategy--- increase minimax depth as the game progress-dynamic_ply :: Int -> Int -> AI-dynamic_ply d1 d2 = AI { name = "dyn" ++ show d1 ++ "_" ++ show d2- , description = "Minimax with dynamic depth " ++ show d1 ++ "," ++ show d2- , strategy = (withNPieces $ \numpieces -> - if numpieces>30 then- minimaxStrategy d1- else- minimaxStrategy d2- )- }--}+-- | type of static evaluation functions+type EvalFunc = Board -> Int --- Minimaxing strategy with alpha-beta and static prunning -minimaxStrategy :: Int -> Strategy-minimaxStrategy n bt rndgen - | endGameTree bt = error "minimaxStrategy: end of game"-minimaxStrategy n bt rndgen = ((m1,m2), rndgen)+-- | 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' bt' = pruneDepth n $ -- ^ prune to depth `n' mapTree eval bt -- ^ apply static evaluation function --- Naive minimax algorithm (not used)--- nodes values are static evaluation scores+-- | Naive minimax algorithm (not used)+-- | nodes values are static evaluation scores minimax :: (Num a, Ord a) => GameTree a m -> a minimax = minimax' 0 @@ -58,7 +36,7 @@ --- Minimax with alpha-beta prunning+-- | Minimax with alpha-beta prunning minimax_ab :: (Num a, Ord a) => a -> a -> GameTree a m -> a minimax_ab = minimax_ab' 0 @@ -71,9 +49,7 @@ where a' | odd depth = -minimax_ab' (1+depth) (-b) (-a) t | otherwise = minimax_ab' (1+depth) a b t ---- Minimax with alpha-beta pruning--- extended to obtain both score and principal variation +-- | Principal Variantions data PV = PV !Int [Move] deriving (Show) instance Eq PV where@@ -85,13 +61,16 @@ negatePV :: PV -> PV negatePV (PV x ms) = PV (-x) ms ++-- | Minimax 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) --- first parameter determines if we negate children scores--- minimaxPV_ab' :: (Num a, Ord a) => Int -> [m] -> a -> a -> GameTree a m -> (a, [m])+-- | 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@@ -100,3 +79,5 @@ | 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++
src/AI/Utils.hs view
@@ -4,17 +4,16 @@ , pruneDepth, pruneBreadth , highFirst, lowFirst , withNPieces, withBoard- , dontPass, singleCaptures --, nubDoubleCaptures+ , dontPass, singleCaptures + , zoneOfControl ) where - import Board import Data.List (nubBy, sortBy, minimumBy) import qualified Data.IntMap as IntMap import System.Random - -- order subtrees with ascending or descending order of static evaluation highFirst, lowFirst :: GameTree Int m -> GameTree Int m highFirst (GameTree x branches) @@ -56,17 +55,20 @@ winOrPreventLoss :: Strategy -> Strategy winOrPreventLoss s (GameTree node branches) = s $ GameTree node branches2 where- winning = [ (m1, b1) | (m1,b1@(GameTree _ branches'))<-branches,- (m2, GameTree _ []) <- branches']- branches1 = (if not (null winning) - then [head winning]- else if length branches<cutoff - then [ (t,b) | (t,b)<-branches, not_losing b] - else branches)- branches2 = if null branches1 then [head branches] else branches1- not_losing (GameTree _ branches) - = null [t | (t, GameTree _ []) <- branches]- cutoff = 100 -- braching upper bound for searching losing moves+ -- 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 @@ -95,13 +97,48 @@ where branches' = [(m, narrow g) | (m,g)<-branches, m/=Pass] -{---- eliminate double-captures that lead to identical boards-nubDoubleCaptures :: Strategy -> Strategy-nubDoubleCaptures s g rndgen = s (narrow g) rndgen- where narrow (GameTree node branches) - = GameTree node $ nubBy equiv [(t, narrow g) | (t,g)<-branches]- equiv ((m1,Just m2),_) ((m2', Just m1'),_)- = fst m1/=fst m2 && m1==m1' && m2==m2'- equiv _ _ = False--}+++-- Estimate the zone of control of the active player+-- i.e., the set of opponent pieces reachable in a turn (two capture moves)+zoneOfControl :: Board -> HalfBoard+zoneOfControl board+ = IntMap.filterWithKey forPiece1 other+ where+ you = active board+ other = inactive board+ who = player board+ -- white pieces that can make at least one capture+ captures = IntMap.filterWithKey forPiece2 you++ forPiece1, forPiece2 :: Position -> Piece -> Bool+ forPiece1 p (_, i) = or $ map (downLine0 i) $ sixLines p+ forPiece2 p (_, h) = or $ map (downLine2 h) $ sixLines p++ downLine0, downLine1, downLine2 :: Int -> [Position] -> Bool++ downLine0 i [] = False+ downLine0 i (p:ps) + = case atPosition board p of+ Nothing -> downLine0 i ps+ Just (who', (_, h)) | who'==who -> + h>=i || (p`IntMap.member`captures && downLine1 i ps)+ Just (_, (_, j)) -> + or $ map (downLine1 (max i j)) $ sixLines p++ downLine1 i [] = False+ downLine1 i (p:ps) + = case atPosition board p of+ Nothing -> downLine1 i ps+ Just (who', (_, h)) | who'==who -> h>=i+ _ -> False++ downLine2 h [] = False+ downLine2 h (p:ps) + = case atPosition board p of+ Nothing -> downLine2 h ps+ Just (who', (_, i)) | who'/=who -> h>=i+ _ -> False+++
src/Board.hs view
@@ -30,13 +30,14 @@ , startBoardTree , mapTree , mapTree'+ , isEmptyTree , endGame- , endGameTree+ , whiteWins --, swapBoard --, swapBoardTree , nextCaptureMoves , nextStackingMoves- , nextTurns+ --, nextTurns , nextMoves , countStacks , sixLines@@ -44,6 +45,7 @@ , emptyBoard , startingBoard , randomBoard+ , randomBoardIO , showTurn , showMove , applyMove@@ -62,18 +64,20 @@ -- | The board state -- | current turn, active player pieces, other player pieces-data Board = Board { player :: !Bool, -- True=white, False=black- move :: !Int, -- 1 or 2- active :: !HalfBoard, - inactive :: !HalfBoard - } deriving (Eq,Show,Read)+data Board + = Board { player :: !Bool, -- next to play (True=White, False=Black)+ move :: !Int, -- first or second move in a turn+ active :: HalfBoard, -- active player's pieces+ inactive :: HalfBoard -- inactive player's pieces+ } deriving (Eq, Show, Read) -- | A Half-board maps (unboxed) positions to pieces type HalfBoard = IntMap Piece -- | The three types of pieces -- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts.-data Type = Tzaar | Tzarra | Tott deriving (Show, Read, Eq, Ord)+data Type = Tzaar | Tzarra | Tott + deriving (Eq, Ord, Show, Read) -- | the type of a piece, and the level of the stack (starting with 1). type Piece = (Type,Int)@@ -90,7 +94,7 @@ | G1 | G2 | G3 | G4 | G5 | G6 | G7 | H1 | H2 | H3 | H4 | H5 | H6 | I1 | I2 | I3 | I4 | I5- deriving (Show,Read, Eq, Ord, Enum, Bounded)+ deriving (Eq, Ord, Enum, Bounded, Show, Read) -- | "Unboxed" integer board positions type Position = Int @@ -107,15 +111,33 @@ data Move = Capture !Position !Position -- from, to | Stack !Position !Position -- only as second move | Pass -- only as second move- deriving (Eq,Show,Read)+ deriving (Eq, Show, Read) -- | A complete turn is a pair of moves type Turn = (Move, Move) -- | A game tree with nodes s and moves m-data GameTree s m = GameTree !s [(m, GameTree s m)] deriving Show+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 type BoardTree = GameTree Board Move @@ -157,7 +179,7 @@ boardSize :: Board -> Int boardSize board = IntMap.size (active board) + IntMap.size (inactive board) -+{- -- | next complete turns for the active player nextTurns :: Board -> [Turn] nextTurns board@@ -173,6 +195,7 @@ captureStack = [ (m,m') | (m, ms)<-zip captures stackings, m'<-ms] captureNothing = zip captures (repeat Pass) lostOneOfThree = any (==0) (countStacks you) +-} -- | next moves for the active player@@ -345,28 +368,25 @@ --- | Check for a end of game position+-- | Check for an end of game position endGame :: Board -> Bool-endGame b = move b==1 && null (nextTurns b)+endGame b = case move b of+ 1 -> lostPieces || nullCaptures+ 2 -> lostPieces'+ _ -> error "endGame: invalid board"+ where lostPieces = any (==0) (countStacks (active b))+ lostPieces'= any (==0) (countStacks (inactive b))+ nullCaptures = null (nextCaptureMoves b) --- | Check for a end of game tree-endGameTree :: GameTree s m -> Bool-endGameTree (GameTree _ []) = True-endGameTree _ = False+-- | 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" --- | some 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]-- -- | Query the state of a board position. atPosition :: Board -> Position -> Maybe (Bool,Piece) atPosition board pos @@ -404,8 +424,7 @@ , [B6, C6, D6, E5, F5, G4, H3, I2] , [C7, D7, E6, F6, G5, H4, I3] , [D8, E7, F7, G6, H5, I4]- , [E8, F8, G7, H6, I5]- + , [E8, F8, G7, H6, I5] , [E1, F1, G1, H1, I1] , [D1, E2, F2, G2, H2, I2] , [C1, D2, E3, F3, G3, H3, I3]@@ -472,6 +491,11 @@ whites = zip (take 30 positions') pieces blacks = zip (drop 30 positions') pieces +randomBoardIO :: IO Board+randomBoardIO = do rnd <- getStdGen+ let (b, rnd') = randomBoard rnd+ setStdGen rnd'+ return b -- an auxilary function to shuffle a list randomly
src/GUI.hs view
@@ -9,97 +9,67 @@ import Graphics.UI.Gtk.Glade import Graphics.Rendering.Cairo import Data.Function (on)-import Data.Maybe (fromJust) import qualified Data.IntMap as IntMap import Data.IntMap (IntMap, (!)) import Data.List (minimumBy, sortBy) import Control.Concurrent-import Control.Monad (when)-import System.Random-import StateVar (StateVar)-import qualified StateVar as StateVar+import Control.Monad (when, filterM)+import System.IO+import System.FilePath+import System.Random hiding (next)+import Var (Var)+import qualified Var as Var+import History (History)+import qualified History as History import Board import AI -- | Piece colors-data PieceColor = White | Black deriving (Eq,Show)+data PieceColor = White | Black + deriving (Eq,Show,Read) --- | Record to hold the game state-data State = State+-- | Record to hold the current game state+data Game = Game { board :: Board -- current board- , moves :: [Move] -- available moves- , trail :: [Move] -- trail from previous turn- , history :: [State] -- undo/redo history- , future :: [State]- , stdGen :: !StdGen -- random number generator- , ai :: AI -- ai player- , stage :: Stage -- selection stage- }---data Stage- = Start0 -- wait for 1st turn - | Start1 Position -- wait for 1st turn (2nd position)- | Wait0 -- wait for move (1st position)- | Wait1 Position -- wait for move (2nd position)- | Wait2 -- end of turn, waiting for AI- | Finish -- game end- deriving Eq-+ , trail :: [Move] -- previous opponent moves + , state :: State -- selection stage+ } deriving (Show, Read) --- | A reference to mutable state-type StateRef = StateVar State+-- | Selection state+data State+ = Start0 -- 1st turn + | Start1 Position -- 1st turn (2nd position)+ | Wait0 -- Nth turn (1st position)+ | Wait1 Position -- Nth turn (2nd position)+ | Wait2 -- wait for AI opponent+ | Finish -- game ended+ deriving (Eq, Show, Read) --- | A state with an empty board (before game starts)-emptyState :: StdGen -> State-emptyState rnd = State { board = emptyBoard,- moves = [],- trail = [],- history = [],- future = [],- stdGen = rnd,- ai = undefined,- stage = Finish- }+-- | reference to a game+type GameRef = Var Game +-- | reference to the history+type HistRef = Var (History Game) --- | Initial game state state --- | standard non-random board-initState :: StdGen -> AI -> State-initState rnd ai - = State { board = startingBoard- , history = []- , moves = nextMoves startingBoard- , trail = []- , future = []- , stdGen = rnd- , ai = ai- , stage = Start0- }---- random board-initRandomState :: StdGen -> AI -> State-initRandomState rnd ai- = State { board = b- , moves = nextMoves b- , trail = []- , history = []- , future = []- , stdGen = rnd'- , ai = ai- , stage = Start0- }- where (b, rnd') = randomBoard rnd-+-- | initialize a game, given a starting board+initGame :: Board -> Game+initGame b+ = Game { board = b+ , trail = []+ , state = Start0+ } --- a record to hold GUI elements+-- | record to hold the GUI state data GUI = GUI { mainwin :: Window, canvas :: DrawingArea, statusbar:: Statusbar, progressbar:: ProgressBar, menu_item_new :: MenuItem,+ menu_item_open :: MenuItem,+ menu_item_save :: MenuItem,+ -- menu_item_save_as :: MenuItem, menu_item_quit :: MenuItem, menu_item_undo :: MenuItem, menu_item_redo :: MenuItem,@@ -107,39 +77,44 @@ menu_item_show_heights :: CheckMenuItem, menu_item_show_moves :: CheckMenuItem, menu_item_random_start :: CheckMenuItem,- menu_item_ai_players :: [RadioMenuItem],+ menu_item_ai_players :: [(RadioMenuItem, AI)],+ open_file_chooser :: FileChooserDialog,+ save_file_chooser :: FileChooserDialog, contextid :: ContextId } -+-- | main GUI entry point gui :: String -> IO () gui gladepath = do initGUI gui <- loadGlade gladepath- rnd <- getStdGen- stateRef <- StateVar.new (emptyState rnd)- connect_events gui stateRef-+ gameRef <- Var.new (initGame startingBoard)+ histRef <- Var.new $ History.init (initGame startingBoard)+ connect_events gui gameRef histRef -- timer event for running other threads timeoutAdd (yield >> return True) 50 -- timer event for updating the progress bar - timeoutAdd (updateProgress gui stateRef >> return True) 100-+ timeoutAdd (Var.get gameRef >>= + updateProgress gui >>+ return True) 100 -- start event loop mainGUI --- load gui elements from XML Glade file+-- | load GUI elements from XML glade file loadGlade gladepath = do out <- xmlNew gladepath- when (out==Nothing) (error "failed to load glade file")+ when (out==Nothing) (error $ "failed to load glade file " ++ show gladepath) let Just xml = out mw <- xmlGetWidget xml castToWindow "mainwindow" fr <- xmlGetWidget xml castToFrame "frame1" sb <- xmlGetWidget xml castToStatusbar "statusbar" pb <- xmlGetWidget xml castToProgressBar "progressbar" mn <- xmlGetWidget xml castToMenuItem "menu_item_new"+ mo <- xmlGetWidget xml castToMenuItem "menu_item_open"+ ms <- xmlGetWidget xml castToMenuItem "menu_item_save"+ -- msa<- xmlGetWidget xml castToMenuItem "menu_item_save_as" mq <- xmlGetWidget xml castToMenuItem "menu_item_quit" mun<- xmlGetWidget xml castToMenuItem "menu_item_undo" mre<- xmlGetWidget xml castToMenuItem "menu_item_redo"@@ -153,149 +128,255 @@ containerAdd fr bd m<- xmlGetWidget xml castToMenu "menu_ai"- r <- radioMenuItemNewWithLabel (name $ head aiPlayers)+ r <- radioMenuItemNewWithLabel (name $ snd $ head aiPlayers) menuAttach m r 0 1 0 1- rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name t) + 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..]] + -- open/save file dialogs+ ff <- fileFilterNew + fileFilterSetName ff "Tzaar saved games (*.tza)"+ fileFilterAddPattern ff "*.tza"+ opf <- fileChooserDialogNew (Just "Open saved game") Nothing FileChooserActionOpen + [("Cancel",ResponseCancel),("Open",ResponseOk)] + fileChooserAddFilter opf ff+ svf <- fileChooserDialogNew (Just "Save game") Nothing FileChooserActionSave+ [("Cancel",ResponseCancel),("Save",ResponseOk)] + fileChooserAddFilter svf ff cid <- statusbarGetContextId sb "status"+ -- statusbarPush sb cid "Ready" widgetShowAll mw- return $ GUI mw bd sb pb mn mq mun mre mpa msh msm mrs (r:rs) cid--+ return (GUI mw bd sb pb mn mo ms mq mun mre mpa + msh msm mrs (zip (r:rs) (map snd aiPlayers)) opf svf cid) -connect_events gui stateRef +-- | connect event handlers for GUI elements+connect_events gui gameRef histRef = do onExpose (canvas gui) $ \x -> - do drawCanvas gui stateRef+ do drawCanvas gui gameRef return (eventSent x) onButtonPress (canvas gui) $ \x -> do mp<-getPosition (canvas gui) (eventX x) (eventY x) case mp of Nothing -> return (eventSent x)- Just p -> do clickPosition gui stateRef p+ Just p -> do clickPosition gui gameRef histRef p return (eventSent x) - sequence_ [ onActivateLeaf item (set_ai player)- | (player,item) <- - zip aiPlayers (menu_item_ai_players gui) ]- onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_quit gui) mainQuit- onActivateLeaf (menu_item_new gui) $ newGame gui stateRef- onActivateLeaf (menu_item_undo gui) $ StateVar.modify stateRef prevHistory- onActivateLeaf (menu_item_redo gui) $ StateVar.modify stateRef nextHistory+ onActivateLeaf (menu_item_new gui) $ newGame gui gameRef histRef+ onActivateLeaf (menu_item_open gui) $ + do { answer<-fileDialogRun (open_file_chooser gui)+ ; case answer of+ Just path -> openGame gameRef histRef path+ Nothing -> return ()+ }+ onActivateLeaf (menu_item_save gui) $ + do { answer<-fileDialogRun (save_file_chooser gui)+ ; case answer of+ Just path -> saveGame gameRef histRef + (replaceExtension path ".tza")+ Nothing -> return ()+ }+ onActivateLeaf (menu_item_undo gui) $ moveUndo gameRef histRef+ onActivateLeaf (menu_item_redo gui) $ moveRedo gameRef histRef - onActivateLeaf (menu_item_pass gui) (movePass gui stateRef)+ onActivateLeaf (menu_item_pass gui) (movePass gui gameRef histRef) onActivateLeaf (menu_item_show_heights gui) $ redrawCanvas (canvas gui) onActivateLeaf (menu_item_show_moves gui) $ redrawCanvas (canvas gui) -- set callback to update the widgets and redraw the canvas- StateVar.watch stateRef $ \s -> do {updateWidgets gui s; redrawCanvas (canvas gui)}+ Var.watch gameRef $ + \g -> do { h<-Var.get histRef+ ; updateWidgets gui g h+ ; redrawCanvas (canvas gui)+ }+ Var.watch histRef $ + \h -> do { g<-Var.get gameRef+ ; updateWidgets gui g h } - where set_ai player = StateVar.modify stateRef $ \s->s{ai=player} +-- | start a new game+newGame :: GUI -> GameRef -> HistRef -> IO ()+newGame gui gameRef histRef+ = do r <- checkMenuItemGetActive (menu_item_random_start gui)+ b <- if r then randomBoardIO else return startingBoard+ Var.set gameRef (initGame b)+ Var.set histRef (History.init $ initGame b) -newGame :: GUI -> StateRef -> IO ()-newGame gui stateRef- = do s <- StateVar.get stateRef- ai <- getAI gui- random <- checkMenuItemGetActive (menu_item_random_start gui)- StateVar.set stateRef $ - if random then initRandomState (stdGen s) ai- else initState (stdGen s) ai- gui `pushMsg` "Ready" +-- | open a saved game+openGame :: GameRef -> HistRef -> FilePath -> IO ()+openGame gameRef histRef filepath+ = withFile filepath ReadMode $ \handle ->+ do txt <- hGetContents handle + case reads txt of+ (((g,h), _): _) -> Var.set gameRef g >> + Var.set histRef h+ _ -> putStrLn ("WARNING: couldn't parse file " ++ show filepath) --- get the selected AI player-getAI :: GUI -> IO AI-getAI gui - = do bs <- sequence [checkMenuItemGetActive item - | item<-menu_item_ai_players gui]- return $ head [ai | (True,ai)<-zip bs aiPlayers] +-- | write a game file+saveGame :: GameRef -> HistRef -> FilePath -> IO ()+saveGame gameRef histRef filepath + = withFile filepath WriteMode $ \handle -> + do g<-Var.get gameRef + h<-Var.get histRef + hPrint handle (g,h) +fileDialogRun :: FileChooserDialog -> IO (Maybe FilePath)+fileDialogRun w = do {dialogRun w ; widgetHide w; fileChooserGetFilename w} --- methods to update the status bar-pushMsg :: GUI -> String -> IO ()-pushMsg gui txt - = statusbarPush (statusbar gui) (contextid gui) txt >> return () -popMsg :: GUI -> IO ()-popMsg gui = statusbarPop (statusbar gui) (contextid gui) >> return ()-+-- | 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")) --- update progress bar if we are waiting for AI-updateProgress :: GUI -> StateRef -> IO ()-updateProgress gui stateRef- = do s <- StateVar.get stateRef- case stage s of- Wait2 -> progressBarPulse (progressbar gui)- _ -> progressBarSetFraction (progressbar gui) 0+-- | update progress bar if we are waiting for AI+updateProgress :: GUI -> Game -> IO ()+updateProgress gui g+ = case state g of+ Wait2 -> progressBarPulse w+ _ -> progressBarSetFraction w 0 + where w = progressbar gui --- update widgets sensitivity -updateWidgets :: GUI -> State -> IO ()-updateWidgets gui s- = do { widgetSetSensitive (menu_item_undo gui) (stage s/=Wait2 && notNull (history s))- ; widgetSetSensitive (menu_item_redo gui) (stage s/=Wait2 && notNull (future s))- ; widgetSetSensitive (menu_item_pass gui) (stage s==Wait0 && move (board s)==2)+-- | update widgets sensitivity +updateWidgets :: GUI -> Game -> History Game -> IO ()+updateWidgets gui g h+ = do { widgetSetSensitive (menu_item_undo gui) $+ s/=Wait2 && not (History.atStart h)+ ; widgetSetSensitive (menu_item_redo gui) $+ s/=Wait2 && not (History.atEnd h)+ ; widgetSetSensitive (menu_item_pass gui) $ + s==Wait0 && move b==2+ ; updateStatus gui msg }- + where b = board g+ s = state g+ color = if player b then "White" else "Black"+ msg = case s of+ Finish -> if whiteWins 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),+ ", move ", show (move b), ")"] +-- | replace the status message+updateStatus :: GUI -> String -> IO ()+updateStatus gui txt+ = statusbarPop w id >> statusbarPush w id txt >> return ()+ where w = statusbar gui+ id = contextid gui++ notNull :: [a] -> Bool notNull = not . null ---- handle undo and redo buttons---- add to history-addHistory :: State -> State-addHistory s = s { history = s:history s, future = [] }+-- | pass the 2nd move of a turn+movePass :: GUI -> GameRef -> HistRef -> IO ()+movePass gui gameRef histRef+ = do g <- Var.get gameRef+ let b = board g+ case state g of+ Wait0 | move b==2 -> + dispatch gui gameRef histRef (makeMove Pass g)+ _ -> return () --- should we record this state ?-recState :: State -> [State] -> [State]-recState s ss - = case stage s of- Start0 -> s:ss- Wait0 -> s:ss- Wait1 _ -> s:ss- Finish -> s:ss- _ -> ss+moveUndo :: GameRef -> HistRef -> IO ()+moveUndo gameRef histRef + = do h <- Var.get histRef+ when (not $ History.atStart h) $+ do Var.set histRef (History.previous h)+ Var.set gameRef (History.get $ History.previous h) --- move backwards/foward in history-prevHistory :: State -> State-prevHistory s - = case history s of- [] -> s- (s':ss) -> s' {history = ss, future = recState s (future s), trail=[]}+moveRedo :: GameRef -> HistRef -> IO ()+moveRedo gameRef histRef + = do h <- Var.get histRef+ when (not $ History.atEnd h) $+ do Var.set histRef (History.next h)+ Var.set gameRef (History.get $ History.next h) -nextHistory :: State -> State-nextHistory s - = case future s of- [] -> s- (s':ss) -> s' {history = recState s (history s), future = ss, trail=[]}+-- | handle a button click on a board position+clickPosition :: GUI -> GameRef -> HistRef -> Position -> IO ()+clickPosition gui gameRef histRef p+ = do g <- Var.get gameRef+ let moves = nextMoves (board g)+ case state g of+ Start0 | p`startMove`moves -> + Var.set gameRef $ g {state=Start1 p}+ Start1 p' | p'==p -> + Var.set gameRef $ g {state=Start0}+ Start1 p' | (Capture p' p)`elem`moves -> + dispatch gui gameRef histRef $+ makeMove Pass (makeMove (Capture p' p) g)+ Wait0 | p`startMove`moves -> + Var.set gameRef $ g {state=Wait1 p, trail=[]}+ Wait1 p' | p'==p -> + Var.set gameRef $ g {state=Wait0}+ Wait1 p' | (Capture p' p)`elem`moves -> + dispatch gui gameRef histRef $+ makeMove (Capture p' p) g+ Wait1 p' | (Stack p' p)`elem`moves -> + dispatch gui gameRef histRef $ + makeMove (Stack p' p) g+ _ -> return ()+ +-- | check if we can start a move from a position+startMove :: Position -> [Move] -> Bool+startMove p moves+ = notNull [p' | Capture p' _<-moves, p'==p] ||+ notNull [p' | Stack p' _<-moves, p'==p] +-- | dispatch a move +dispatch :: GUI -> GameRef -> HistRef -> Game -> IO ()+dispatch gui gameRef histRef g+ = case state g of+ Wait0 -> Var.modify histRef (History.record g') >>+ Var.set gameRef g + Finish -> Var.modify histRef (History.record g') >>+ Var.set gameRef g + Wait2 -> Var.set gameRef g >>+ forkIO runAI >> return ()+ _ -> Var.set gameRef g+ where + g' = g { trail=[] }+ -- run the AI player asynchronously + runAI = do { rnd <- getStdGen+ ; ai <- getAI gui+ ; let b = board g+ ; let ((m1,m2), rnd') = strategy ai (boardTree b) rnd+ ; setStdGen rnd'+ ; let g' = makeMove m2 $ makeMove m1 $ g { trail=[] }+ -- force evaluation in this thread+ ; m1 `seq` m2 `seq` + Var.modify histRef (History.record g')+ ; Var.set gameRef g' + } --- pass the 2nd move of a turn-movePass :: GUI -> StateRef -> IO ()-movePass gui stateRef - = do s <- StateVar.get stateRef- let b = board s- case stage s of- Wait0 | move b==2 -> dispatch gui stateRef (applyMove b Pass)- _ -> return ()+makeMove :: Move -> Game -> Game+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 +---------------------------------------------------------------------------------+-- | drawing methods+--------------------------------------------------------------------------------- redrawCanvas :: DrawingArea -> IO () redrawCanvas canvas = do (w,h)<-widgetGetSize canvas@@ -304,24 +385,24 @@ -- redraw the canvas using double-buffering-drawCanvas :: GUI -> StateRef -> IO ()-drawCanvas gui stateRef +drawCanvas :: GUI -> GameRef -> IO ()+drawCanvas gui gameRef = do b1 <- checkMenuItemGetActive (menu_item_show_heights gui) b2 <- checkMenuItemGetActive (menu_item_show_moves gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui)- s <- StateVar.get stateRef+ g <- Var.get gameRef renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp -> - do renderWith tmp (setTransform w h >> renderBoard b1 b2 s)+ do renderWith tmp (setTransform w h >> renderBoard b1 b2 g) setSourceSurface tmp 0 0 paint -- render the board and pieces-renderBoard :: Bool -> Bool -> State -> Render ()-renderBoard showheights showmoves state+renderBoard :: Bool -> Bool -> Game -> Render ()+renderBoard showheights showmoves g = do -- paint the background boardBg >> paint -- paint the playing area light gray@@ -333,23 +414,24 @@ -- draw the grid and coordinates renderGrid -- draw the pieces & highlight selection- case stage state of+ case state g of Start0 -> pieces showheights b Start1 p -> do highlight p pieces showheights b when showmoves $ mapM_ renderMove (targets p) Wait0 -> do pieces showheights b- when showmoves $ mapM_ renderMove (trail state)+ when showmoves $ mapM_ renderMove (trail g) Wait1 p -> do highlight p pieces showheights b when showmoves $ mapM_ renderMove (targets p) Wait2 -> do pieces showheights b- when showmoves $ mapM_ renderMove (trail state)+ when showmoves $ mapM_ renderMove (trail g) Finish -> do pieces showheights b- when showmoves $ mapM_ renderMove (trail state)- where b = board state- targets p = [m | m@(Capture p1 p2)<-moves state, p1==p] ++ - [m | m@(Stack p1 p2)<-moves state, p1==p]+ when showmoves $ mapM_ renderMove (trail g)+ where b = board g+ moves = nextMoves b+ targets p = [m | m@(Capture p1 p2)<-moves, p1==p] ++ + [m | m@(Stack p1 p2)<-moves, p1==p] renderMove :: Move -> Render () renderMove (Capture p1 p2) = do setSourceRGBA 1 0 0 0.7@@ -523,66 +605,6 @@ --- dispatch a button click on a board position--- check move is valid from this position-clickPosition :: GUI -> StateRef -> Position -> IO ()-clickPosition gui stateRef p- = do s <- StateVar.get stateRef - case stage s of- Start0 | notNull [p0 | (Capture p0 _)<-moves s, p0==p] -> - let s'= addHistory s- in StateVar.set stateRef $ s' {stage=Start1 p}- Start1 p0 | p0==p -> StateVar.modify stateRef prevHistory-- Start1 p0 | Capture p0 p `elem` moves s -> - do StateVar.modify stateRef $ - \s -> s{trail=Capture p0 p:trail s}- dispatch gui stateRef (applyTurn (board s) (Capture p0 p,Pass))- Wait0 | notNull [p0 | Capture p0 _<-moves s, p0==p] || - notNull [p0 | Stack p0 _<-moves s, p0==p] -> - let s'= addHistory s - in StateVar.set stateRef $ s' {stage=Wait1 p, trail=[]}- Wait1 p0 | p0==p -> StateVar.modify stateRef prevHistory- Wait1 p0 | Capture p0 p`elem`moves s -> - do StateVar.modify stateRef $ - \s -> s {trail = Capture p0 p : trail s}- dispatch gui stateRef (applyMove (board s) (Capture p0 p))- Wait1 p0 | Stack p0 p`elem`moves s -> - do StateVar.modify stateRef $- \s -> s {trail = Stack p0 p : trail s}- dispatch gui stateRef (applyMove (board s) (Stack p0 p))- _ -> return ()---dispatch :: GUI -> StateRef -> Board -> IO ()-dispatch gui stateRef b- | endGame b = do { gui `pushMsg` - (if player b then "Black wins" else "White wins")- ; StateVar.modify stateRef $ - \s -> s {stage=Finish, board=b, moves=[]}- } - | player b -- White to move- = StateVar.modify stateRef $ - \s -> s {stage=Wait0, board=b, moves=nextMoves b}- | otherwise -- Black to move- = do { gui `pushMsg` "Thinking..."- ; StateVar.modify stateRef $ \s -> s{stage=Wait2, moves=[], board=b}- ; forkIO async- ; return ()- }- where - -- asynchronous action for the AI player- async = do { s <- StateVar.get stateRef - ; let b = board s- ; let bt = boardTree b- ; let (t@(m1,m2), rnd') = strategy (ai s) bt (stdGen s)- ; gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t)- ; StateVar.modify stateRef $ \s -> s { stdGen = rnd'- , trail = [m1,m2] - }- ; dispatch gui stateRef (applyTurn b t)- }-
+ src/History.hs view
@@ -0,0 +1,67 @@+-- Module for undo/redo navigation +--+-- the history maintains a cursor in a sequence +--+-- pbv, 2011+module History where+import Prelude hiding (length)+import qualified Prelude (length)+++-- | data type for history+data History a = + History { back :: [a], + front :: [a]+ } deriving (Eq, Show, Read)+ +-- | initialize history+init :: a -> History a +init x = History {back=[x], front=[]}+++atStart :: History a -> Bool+atStart = singleton . back ++singleton :: [a] -> Bool+singleton [_] = True+singleton _ = False++atEnd :: History a -> Bool+atEnd = null . front++length :: History a -> Int+length h = Prelude.length (back h) + Prelude.length (front h)++position :: History a -> Int+position h = Prelude.length (back h)+++-- | navigate backwards+previous :: History a -> History a+previous h+ = case back h of + [x] -> h+ (x:xs) -> History { back = xs, front = x:front h }++-- | navigate forwards+next :: History a -> History a+next h+ = case front h of + [] -> h+ (x:xs) -> History { back = x:back h, front = xs }+++-- | record at the current point +-- obliviates next entries+record :: a -> History a -> History a+record x h = History { back = x:back h, front = [] }++-- | get the cursor value+get :: History a -> a+get h = case back h of+ (x:_) -> x+ [] -> error "History.get: no value"++++
src/Main.hs view
@@ -37,7 +37,7 @@ header, footer :: String header = "usage: hstzaar [OPTION..] [AI AI]"-footer = " where AI is one of: " ++ unwords [name ai | ai<-aiPlayers]+footer = "\twhere AI is one of: " ++ unwords (map fst aiPlayers) -- default number of matches for AI tournaments@@ -62,18 +62,16 @@ case argv' of [] -> do gladepath <- getDataFileName "data/hstzaar.glade" gui gladepath- [a1,a2] -> do p1<-string_to_AI a1- p2<-string_to_AI a2- let numboards = max 1 (numMatches`div`2)- rndgen <- getStdGen- let (boards, rnd) = randomBoards numboards rndgen- playAIs p1 p2 boards rnd+ [a1,a2] | a1`elem`ais && a2`elem`ais-> + do let numboards = max 1 (numMatches`div`2)+ rndgen <- getStdGen+ let (boards, rnd) = randomBoards numboards rndgen+ playAIs (toAI a1) (toAI a2) boards rnd _ -> ioError $ userError $ usageInfo header options ++ footer+ where ais = map fst aiPlayers -string_to_AI :: String -> IO AI-string_to_AI n - = case [p | p<-aiPlayers, name p==n] of- [] -> ioError $ userError ("invalid AI: " ++ n)- (p:_) -> return p ++toAI :: String -> AI+toAI ai = maybe (error ("invalid ai: "++ai)) id (lookup ai aiPlayers)
− src/StateVar.hs
@@ -1,49 +0,0 @@--- State variables for IO refs--- Encapsulates mutable references with callback functions --- pbv, 2011-module StateVar- ( StateVar,- new, get, set, modify, watch- ) where--import Data.IORef---- a state variable is pair of mutable ref and mutable callback-data StateVar a = StateVar !(IORef a) !(IORef (a -> IO ()))---- make a new state var with given value and null callback-new :: a -> IO (StateVar a)-new v = do ref <- newIORef v- callback <- newIORef (\_ -> return ())- return (StateVar ref callback)---- assign to a state var-set :: StateVar a -> a -> IO ()-set (StateVar ref callback) v- = do writeIORef ref v- cb <- readIORef callback - cb v---- fetch the value of a state var-get :: StateVar a -> IO a-get (StateVar ref _) = readIORef ref---- update a state var using a pure function-modify :: StateVar a -> (a -> a) -> IO ()-modify (StateVar ref callback) f- = do modifyIORef ref f- v <- readIORef ref- cb <- readIORef callback- cb v---- modify the callback for a state var--- finishes executing the callback with current value-watch :: StateVar a -> (a -> IO ()) -> IO ()-watch (StateVar ref callback) cb - = do writeIORef callback cb- v <- readIORef ref- cb v-- --
src/Tests.hs view
@@ -47,17 +47,17 @@ prop_value_bounds :: Board -> Property prop_value_bounds board = not (active_lost board) && not (inactive_lost board) ==> abs value < infinity- where value = eval board+ where value = eval1 board -- end game positions give plus/minus infinityinity scores prop_inactive_lost :: Board -> Property prop_inactive_lost b- = not (active_lost b) && inactive_lost b ==> eval b == infinity + = not (active_lost b) && inactive_lost b ==> eval1 b == infinity prop_active_lost :: Board -> Property prop_active_lost b- = not (inactive_lost b) && active_lost b ==> eval b == (-infinity)+ = not (inactive_lost b) && active_lost b ==> eval1 b == (-infinity) -- correcteness of alpha-beta pruning against plain minimax @@ -66,7 +66,7 @@ prop_alpha_beta npieces depth = forAllShrink (resize npieces arbitrary) shrink $ \b -> admissible b ==>- let bt = mkTree depth b+ let bt = mkTree depth eval1 b in minimax_ab (-infinity) infinity bt == minimax bt @@ -77,7 +77,7 @@ | depth`mod`4 == 0 = forAllShrink (resize npieces arbitrary) shrink $ \b -> admissible b ==> - let bt = mkTree depth b+ let bt = mkTree depth eval1 b (v,ms)= minimaxPV bt (GameTree v' _) = foldl treeMove bt ms in neg (length ms) v'==v@@ -85,8 +85,8 @@ | n`mod`4==2 = -x -mkTree :: Int -> Board -> GameTree Int Move-mkTree depth board = pruneDepth depth $ mapTree eval $ boardTree board+mkTree :: Int -> EvalFunc -> Board -> GameTree Int Move+mkTree depth eval board = pruneDepth depth $ mapTree eval $ boardTree board treeMove :: Eq m => GameTree s m -> m -> GameTree s m
src/Tournament.hs view
@@ -1,8 +1,6 @@ -- Competitions between diferent AIs module Tournament where -import AI.Minimax-import AI.Lame import Board import System.Random import Control.Monad
+ src/Var.hs view
@@ -0,0 +1,49 @@+-- State variables for IO refs+-- Encapsulates mutable references with callback functions +-- pbv, 2011+module Var+ ( Var,+ new, get, set, modify, watch+ ) where++import Data.IORef++-- a state variable is pair of mutable ref and mutable callback+data Var a = Var !(IORef a) !(IORef (a -> IO ()))++-- make a new state var with given value and null callback+new :: a -> IO (Var a)+new v = do ref <- newIORef v+ callback <- newIORef (\_ -> return ())+ return (Var ref callback)++-- assign to a state var+set :: Var a -> a -> IO ()+set (Var ref callback) v+ = do writeIORef ref v+ cb <- readIORef callback + cb v++-- fetch the value of a state var+get :: Var a -> IO a+get (Var ref _) = readIORef ref++-- update a state var using a pure function+modify :: Var a -> (a -> a) -> IO ()+modify (Var ref callback) f+ = do modifyIORef ref f+ v <- readIORef ref+ cb <- readIORef callback+ cb v++-- modify the callback for a state var+-- finishes executing the callback with current value+watch :: Var a -> (a -> IO ()) -> IO ()+watch (Var ref callback) cb + = do writeIORef callback cb+ v <- readIORef ref+ cb v++ ++