diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -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 diff --git a/data/hstzaar.glade b/data/hstzaar.glade --- a/data/hstzaar.glade +++ b/data/hstzaar.glade @@ -1,6 +1,6 @@ - + HsTZAAR @@ -45,14 +45,6 @@ - - gtk-save-as - True - True - True - - - True @@ -129,13 +121,15 @@ True Show heights True + True True - Show available moves + Show moves True + True diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -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, diff --git a/src/AI.hs b/src/AI.hs --- a/src/AI.hs +++ b/src/AI.hs @@ -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 ) } diff --git a/src/AI/Eval.hs b/src/AI/Eval.hs --- a/src/AI/Eval.hs +++ b/src/AI/Eval.hs @@ -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 diff --git a/src/AI/Lame.hs b/src/AI/Lame.hs deleted file mode 100644 --- a/src/AI/Lame.hs +++ /dev/null @@ -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 - - diff --git a/src/AI/Minimax.hs b/src/AI/Minimax.hs --- a/src/AI/Minimax.hs +++ b/src/AI/Minimax.hs @@ -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 + + diff --git a/src/AI/Utils.hs b/src/AI/Utils.hs --- a/src/AI/Utils.hs +++ b/src/AI/Utils.hs @@ -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 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 + + + diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -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 diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -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) - } - diff --git a/src/History.hs b/src/History.hs new file mode 100644 --- /dev/null +++ b/src/History.hs @@ -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" + + + + diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/StateVar.hs b/src/StateVar.hs deleted file mode 100644 --- a/src/StateVar.hs +++ /dev/null @@ -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 - - - - diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -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 diff --git a/src/Tournament.hs b/src/Tournament.hs --- a/src/Tournament.hs +++ b/src/Tournament.hs @@ -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 diff --git a/src/Var.hs b/src/Var.hs new file mode 100644 --- /dev/null +++ b/src/Var.hs @@ -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 + + + +