diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -1,3 +1,7 @@ +0.9.3 11/03/2013 +- added an command line option to ask for an AI move for + a given board configuration + 0.9.2 30/08/2012 - removed bogus dependency on haskell98 package - changed AI code to use a type class for generating gametrees; diff --git a/hstzaar.cabal b/hstzaar.cabal --- a/hstzaar.cabal +++ b/hstzaar.cabal @@ -1,5 +1,5 @@ name: hstzaar -version: 0.9.2 +version: 0.9.3 category: Game diff --git a/src/Board.hs b/src/Board.hs --- a/src/Board.hs +++ b/src/Board.hs @@ -34,6 +34,7 @@ , showMove , applyMove , applyMoveSkip + , applyMoveSkip' , positions , zoneOfControl ) where @@ -109,7 +110,7 @@ -- | initialize a board from a list of piece & positions initBoard :: [(Position,Piece)] -> Board -initBoard assocs +initBoard assocs = let ps = Map.fromList assocs in Board { active=White, move=0, moves=[], pieces=ps, activeCounts=countStacks White ps, @@ -342,11 +343,22 @@ applyMoveSkip :: Move -> Board -> Board applyMoveSkip m b = case nextMoves b' of - [Skip] -> applyMove Skip b' -- compulsory move + (Skip:_) -> applyMove Skip b' -- compulsory move _ -> b' where b' = applyMove m b +-- | apply one move checking for validity +applyMoveSkip' :: Board -> Move -> Maybe Board +applyMoveSkip' b m + | m`elem`ms = + case nextMoves b' of + (Skip:_) -> Just (applyMove Skip b') + _ -> Just b' + | otherwise = Nothing + where ms = nextMoves b + b' = applyMove m b + endGame :: Board -> Bool endGame = null . nextMoves @@ -415,7 +427,7 @@ -- | The default (non-randomized, non-tournament) starting position. startingBoard :: Board -startingBoard = initBoard (whites ++ blacks) +startingBoard = initBoard (whites ++ blacks) where whites = [(p, (White,Tzaar,1)) | p<-wTzaars] ++ [(p, (White,Tzarra,1)) | p<-wTzarras] ++ @@ -434,7 +446,7 @@ -- | A randomized starting position randomBoard :: StdGen -> (Board, StdGen) randomBoard rnd = (b, rnd') - where b = initBoard (whites++blacks) + where b = initBoard (whites++blacks) ws = replicate 6 (White,Tzaar,1) ++ replicate 9 (White,Tzarra,1) ++ replicate 15 (White,Tott,1) diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -179,7 +179,8 @@ onActivateLeaf (menu_item_open gui) $ do { answer<-fileDialogRun (open_file_chooser gui) ; case answer of - Just path -> do openGame gamev path + Just path -> do ai <- getAI gui + openGame ai gamev path redrawCanvas (canvas gui) Nothing -> return () } @@ -217,14 +218,24 @@ -- | open a saved game -openGame :: MVar (Game,State) -> FilePath -> IO () -openGame gamev filepath +openGame :: AI -> MVar (Game,State) -> FilePath -> IO () +openGame ai gamev filepath = withFile filepath ReadMode $ \handle -> do txt <- hGetContents handle case readXML txt of - Nothing -> putStrLn ("ERROR: couldn't parse game file " ++ show filepath) - Just g -> let s = if endGame (board g) then Finish else Wait0 - in modifyMVar_ gamev $ \_ -> return (g,s) + Nothing -> + putStrLn ("ERROR: couldn't parse game file " ++ show filepath) + Just g -> + let b = board g + in modifyMVar_ gamev $ + \_ -> if endGame b then + return (g,Finish) + else if active b == human g then + return (g,Wait0) + else do { mvar <- newEmptyMVar + ; forkOS $ runAI ai b mvar + ; return (g,WaitAI mvar) + } -- | write a game file diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,12 @@ -- Main module for Haskell TZAAR game implementation --- Pedro Vasconcelos, 2010 +-- Pedro Vasconcelos, 2010-2013 module Main (main) where import Paths_hstzaar import Board import AI import GUI +import Serialize import Tournament import Tests import Data.List (intersperse) @@ -45,8 +46,8 @@ concat errs ++ usageInfo header options ++ footer header, footer :: String -header = "usage: hstzaar [OPTION..] [AI AI]" -footer = "\twhere AI is one of: " ++ unwords (map (show.name) aiPlayers) +header = "usage: hstzaar [OPTION..] [AI] [AI]" +footer = "\twhere AI is one of: " ++ unwords (map name aiPlayers) -- default number of matches for AI tournaments @@ -63,6 +64,7 @@ main :: IO () main = do argv<-getArgs + rnd <- getStdGen (flags, argv')<- parseArgs argv processFlags flags dir <- getDataDir @@ -71,6 +73,15 @@ -- case argv' of [] -> gui gladepath + [arg1] -> case lookupAI arg1 aiPlayers of + Nothing -> ioError $ + userError $ "invalid AI: " ++ arg1 + Just ai -> + do { txt <- getContents -- read start position + ; case readXML txt of + Nothing -> putStrLn "ERROR: couldn't parse game file" + Just g -> playAI rnd ai (board g) + } [arg1,arg2] -> case do p1 <- lookupAI arg1 aiPlayers p2 <- lookupAI arg2 aiPlayers @@ -78,11 +89,17 @@ of Nothing -> ioError $ userError $ "invalid AI: " ++ unwords [arg1, arg2] Just (p1,p2) -> - do rnd <- getStdGen - let (boards, rnd') = randomBoards numMatches rnd + do let (boards, rnd') = randomBoards numMatches rnd setStdGen rnd' playAIs p1 p2 boards rnd _ -> ioError $ userError $ usageInfo header options ++ footer + +playAI :: StdGen -> AI -> Board -> IO () +playAI rnd ai b + | endGame b = putStrLn ("Game end (" ++ show (invert $ active b) ++ " won)") + | otherwise = putStrLn (show (active b) ++ ": " ++ showMove m) + where (score, m, _) = playing ai b rnd + diff --git a/src/Serialize.hs b/src/Serialize.hs --- a/src/Serialize.hs +++ b/src/Serialize.hs @@ -7,6 +7,7 @@ import Text.XML.Light import qualified Data.Map as Map import Board +import Control.Monad -- | convertion to/from XML elements class ToXML a where @@ -47,7 +48,8 @@ instance Node Board where - node qn b = node qn $ + node qn b = -- add_attr (attr "active" (show $ active b)) $ + node qn $ map (Elem . node (unqual "piece") . PosPiece) $ Map.assocs (pieces b) @@ -64,6 +66,7 @@ toXML = node (unqual "hstzaar") instance FromXML Board where + -- defaults to White active player fromXML el = return (initBoard assocs) where assocs = catMaybes [do { c<-readAttr (unqual "color") el' @@ -75,20 +78,20 @@ instance FromXML MoveList where - fromXML el = Just (MoveList moves) - where moves = catMaybes - [ readMove (strContent el') - | el'<-findChildren (unqual "move") el] + fromXML el = liftM MoveList $ + sequence [ readMove (strContent el') + | el'<-findChildren (unqual "move") el] instance FromXML Game where fromXML el = do el1 <- findChild (unqual "board") el el2 <- findChild (unqual "moves") el - c <- readAttr (unqual "human") el -- human player color b <- fromXML el1 MoveList ms <- fromXML el2 + c <- readOptAttr White (unqual "human") el -- human player color let g = initGame b c - let b' = foldr applyMoveSkip b (reverse ms) + -- let b'= foldr applyMoveSkip b (reverse ms) + b' <- foldM applyMoveSkip' b ms return g { board=b', trail=reverse ms } @@ -107,6 +110,12 @@ [] -> Nothing (a,_):_ -> Just a +readOptAttr :: Read a => a -> QName -> Element -> Maybe a +readOptAttr def name el + = case findAttr name el of + Nothing -> Just def + Just txt -> case reads txt of [] -> Nothing + (a,_):_ -> Just a readMove :: String -> Maybe Move readMove [a,b,'x',c,d] = do (from,_) <- listToMaybe (reads [a,b])