hstzaar 0.9.2 → 0.9.3
raw patch · 6 files changed
+76/−23 lines, 6 files
Files
- RELEASE-NOTES +4/−0
- hstzaar.cabal +1/−1
- src/Board.hs +16/−4
- src/GUI.hs +17/−6
- src/Main.hs +22/−5
- src/Serialize.hs +16/−7
RELEASE-NOTES view
@@ -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;
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.9.2+version: 0.9.3 category: Game
src/Board.hs view
@@ -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)
src/GUI.hs view
@@ -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
src/Main.hs view
@@ -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+
src/Serialize.hs view
@@ -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])