hstzaar 0.7 → 0.8
raw patch · 7 files changed
+365/−359 lines, 7 filesdep +directory
Dependencies added: directory
Files
- RELEASE-NOTES +7/−0
- data/hstzaar.glade +0/−208
- hstzaar.cabal +3/−2
- hstzaar.glade +208/−0
- src/AI.hs +1/−1
- src/GUI.hs +122/−134
- src/Main.hs +24/−14
RELEASE-NOTES view
@@ -1,3 +1,10 @@+hstzaar 0.8 30/06/2011+- fixed crash on clicking Cancel button of file dialogs+- fixed incorrect behaviour of AI Level 2 (wrong comparison)+- added a command-line option to specify glade data directory+- fused game and history references in GUI code;+ should reduce the number of screen redraw events+ hstzaar 0.7 17/06/2011 - improved AI: level 0 does material evaluation only
− data/hstzaar.glade
@@ -1,208 +0,0 @@-<?xml version="1.0" encoding="UTF-8"?>-<glade-interface>- <!-- interface-requires gtk+ 2.16 -->- <!-- interface-naming-policy toplevel-contextual -->- <widget class="GtkWindow" id="mainwindow">- <property name="title" translatable="yes">HsTZAAR</property>- <property name="default_width">600</property>- <property name="default_height">600</property>- <child>- <widget class="GtkVBox" id="vbox1">- <property name="visible">True</property>- <child>- <widget class="GtkMenuBar" id="menubar1">- <property name="visible">True</property>- <child>- <widget class="GtkMenuItem" id="menuitem1">- <property name="visible">True</property>- <property name="label" translatable="yes">_Game</property>- <property name="use_underline">True</property>- <child>- <widget class="GtkMenu" id="menu1">- <property name="visible">True</property>- <child>- <widget class="GtkImageMenuItem" id="menu_item_new">- <property name="label">gtk-new</property>- <property name="visible">True</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- </widget>- </child>- <child>- <widget class="GtkImageMenuItem" id="menu_item_open">- <property name="label">gtk-open</property>- <property name="visible">True</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- </widget>- </child>- <child>- <widget class="GtkImageMenuItem" id="menu_item_save">- <property name="label">gtk-save</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>- </child>- <child>- <widget class="GtkImageMenuItem" id="menu_item_quit">- <property name="label">gtk-quit</property>- <property name="visible">True</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- </widget>- </child>- </widget>- </child>- </widget>- </child>- <child>- <widget class="GtkMenuItem" id="menuitem2">- <property name="visible">True</property>- <property name="label" translatable="yes">_Move</property>- <property name="use_underline">True</property>- <child>- <widget class="GtkMenu" id="menu2">- <property name="visible">True</property>- <child>- <widget class="GtkImageMenuItem" id="menu_item_undo">- <property name="label">gtk-undo</property>- <property name="visible">True</property>- <property name="use_underline">True</property>- <property name="use_stock">True</property>- </widget>- </child>- <child>- <widget class="GtkImageMenuItem" id="menu_item_redo">- <property name="label">gtk-redo</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="menuitem5">- <property name="visible">True</property>- </widget>- </child>- <child>- <widget class="GtkMenuItem" id="menu_item_pass">- <property name="visible">True</property>- <property name="label" translatable="yes">Pass</property>- <property name="use_underline">True</property>- </widget>- </child>- </widget>- </child>- </widget>- </child>- <child>- <widget class="GtkMenuItem" id="menuitem3">- <property name="visible">True</property>- <property name="label" translatable="yes">_Options</property>- <property name="use_underline">True</property>- <child>- <widget class="GtkMenu" id="menu4">- <property name="visible">True</property>- <child>- <widget class="GtkCheckMenuItem" id="menu_item_random_start">- <property name="visible">True</property>- <property name="label" translatable="yes">Random start position</property>- <property name="use_underline">True</property>- </widget>- </child>- <child>- <widget class="GtkCheckMenuItem" id="menu_item_show_heights">- <property name="visible">True</property>- <property name="label" translatable="yes">Show heights</property>- <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 moves</property>- <property name="use_underline">True</property>- <property name="active">True</property>- </widget>- </child>- <child>- <widget class="GtkMenuItem" id="menuitem4">- <property name="visible">True</property>- <property name="label" translatable="yes">_AI</property>- <property name="use_underline">True</property>- <child>- <widget class="GtkMenu" id="menu_ai">- <property name="visible">True</property>- </widget>- </child>- </widget>- </child>- </widget>- </child>- </widget>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkFrame" id="frame1">- <property name="visible">True</property>- <property name="label_xalign">0</property>- <property name="label_yalign">0</property>- <property name="shadow_type">none</property>- <child>- <placeholder/>- </child>- <child>- <placeholder/>- <packing>- <property name="type">label_item</property>- </packing>- </child>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- <child>- <widget class="GtkHBox" id="hbox1">- <property name="visible">True</property>- <property name="homogeneous">True</property>- <child>- <widget class="GtkProgressBar" id="progressbar">- <property name="visible">True</property>- <property name="ellipsize">end</property>- </widget>- <packing>- <property name="position">0</property>- </packing>- </child>- <child>- <widget class="GtkStatusbar" id="statusbar">- <property name="visible">True</property>- <property name="spacing">2</property>- </widget>- <packing>- <property name="position">1</property>- </packing>- </child>- </widget>- <packing>- <property name="expand">False</property>- <property name="position">2</property>- </packing>- </child>- </widget>- </child>- </widget>-</glade-interface>
hstzaar.cabal view
@@ -1,5 +1,5 @@ name: hstzaar-version: 0.7+version: 0.8 category: Game @@ -22,7 +22,7 @@ build-type: Simple cabal-version: >= 1.6-data-files: data/hstzaar.glade+data-files: hstzaar.glade extra-source-files: RELEASE-NOTES @@ -35,6 +35,7 @@ base >= 4 && < 5, haskell98, filepath >= 1.1,+ directory >= 1.0, containers, gtk >=0.11, cairo >= 0.11,
+ hstzaar.glade view
@@ -0,0 +1,208 @@+<?xml version="1.0" encoding="UTF-8"?>+<glade-interface>+ <!-- interface-requires gtk+ 2.16 -->+ <!-- interface-naming-policy toplevel-contextual -->+ <widget class="GtkWindow" id="mainwindow">+ <property name="title" translatable="yes">HsTZAAR</property>+ <property name="default_width">600</property>+ <property name="default_height">600</property>+ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkMenuBar" id="menubar1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkMenuItem" id="menuitem1">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Game</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_new">+ <property name="label">gtk-new</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_open">+ <property name="label">gtk-open</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_save">+ <property name="label">gtk-save</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>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_quit">+ <property name="label">gtk-quit</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menuitem2">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Move</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu2">+ <property name="visible">True</property>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_undo">+ <property name="label">gtk-undo</property>+ <property name="visible">True</property>+ <property name="use_underline">True</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkImageMenuItem" id="menu_item_redo">+ <property name="label">gtk-redo</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="menuitem5">+ <property name="visible">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menu_item_pass">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Pass</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menuitem3">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Options</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu4">+ <property name="visible">True</property>+ <child>+ <widget class="GtkCheckMenuItem" id="menu_item_random_start">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Random start position</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkCheckMenuItem" id="menu_item_show_heights">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Show heights</property>+ <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 moves</property>+ <property name="use_underline">True</property>+ <property name="active">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="menuitem4">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_AI</property>+ <property name="use_underline">True</property>+ <child>+ <widget class="GtkMenu" id="menu_ai">+ <property name="visible">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkFrame" id="frame1">+ <property name="visible">True</property>+ <property name="label_xalign">0</property>+ <property name="label_yalign">0</property>+ <property name="shadow_type">none</property>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ <packing>+ <property name="type">label_item</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox1">+ <property name="visible">True</property>+ <property name="homogeneous">True</property>+ <child>+ <widget class="GtkProgressBar" id="progressbar">+ <property name="visible">True</property>+ <property name="ellipsize">end</property>+ </widget>+ <packing>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkStatusbar" id="statusbar">+ <property name="visible">True</property>+ <property name="spacing">2</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">2</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+</glade-interface>
src/AI.hs view
@@ -24,7 +24,7 @@ level2 = AI { name = "Level 2" , description = "Minimaxing alpha-beta depth 2-4 (eval1)" , strategy = (withNPieces $ \numpieces -> - if numpieces>30 then+ if numpieces<30 then minimaxStrategy 4 eval1 else minimaxStrategy 2 eval1
src/GUI.hs view
@@ -13,7 +13,7 @@ import Data.IntMap (IntMap, (!)) import Data.List (minimumBy, sortBy) import Control.Concurrent-import Control.Monad (when, filterM)+import Control.Monad (when, filterM, liftM, mplus, msum) import System.IO import System.FilePath import System.Random hiding (next)@@ -45,12 +45,12 @@ | Finish -- game ended deriving (Eq, Show, Read) --- | reference to a game-type GameRef = Var Game --- | reference to the history-type HistRef = Var (History Game)+-- | pair of current game and history+type GameHist = (Game,History Game) +-- | reference to a game and history+type GameRef = Var GameHist -- | initialize a game, given a starting board initGame :: Board -> Game@@ -84,18 +84,18 @@ } -- | main GUI entry point-gui :: String -> IO ()-gui gladepath = +gui :: FilePath -> IO ()+gui path = do initGUI- gui <- loadGlade gladepath- gameRef <- Var.new (initGame startingBoard)- histRef <- Var.new $ History.init (initGame startingBoard)- connect_events gui gameRef histRef+ gui <- loadGlade path+ let g = initGame startingBoard+ gameRef <- Var.new (g, History.init g)+ connect_events gui gameRef -- timer event for running other threads timeoutAdd (yield >> return True) 50 -- timer event for updating the progress bar - timeoutAdd (Var.get gameRef >>= - updateProgress gui >>+ timeoutAdd (Var.get gameRef >>= \(g,_) -> + updateProgress gui g >> return True) 100 -- start event loop mainGUI@@ -103,57 +103,54 @@ -- | load GUI elements from XML glade file-loadGlade gladepath =- do out <- xmlNew gladepath- 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"- mpa<- xmlGetWidget xml castToMenuItem "menu_item_pass"- msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights"- msm<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_moves"- mrs<- xmlGetWidget xml castToCheckMenuItem "menu_item_random_start"+loadGlade :: FilePath -> IO GUI+loadGlade path =+ do out <- xmlNew path+ case out of + Nothing -> error ("unable to open glade file " ++ show path)+ Just xml -> + do 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"+ mq <- xmlGetWidget xml castToMenuItem "menu_item_quit"+ mun<- xmlGetWidget xml castToMenuItem "menu_item_undo"+ mre<- xmlGetWidget xml castToMenuItem "menu_item_redo"+ mpa<- xmlGetWidget xml castToMenuItem "menu_item_pass"+ msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights"+ msm<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_moves"+ mrs<- xmlGetWidget xml castToCheckMenuItem "menu_item_random_start"+ -- fill in dynamic parts+ bd <- drawingAreaNew+ containerAdd fr bd+ m<- xmlGetWidget xml castToMenu "menu_ai"+ r <- radioMenuItemNewWithLabel (name $ snd $ head aiPlayers)+ menuAttach m r 0 1 0 1+ rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t) + menuAttach m w 0 1 i (i+1)+ return w+ | (t,i)<-zip (tail aiPlayers) [1..]]+ -- 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"+ widgetShowAll mw+ 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) - -- fill in dynamic parts- bd <- drawingAreaNew- containerAdd fr bd- - m<- xmlGetWidget xml castToMenu "menu_ai"- r <- radioMenuItemNewWithLabel (name $ snd $ head aiPlayers)- menuAttach m r 0 1 0 1- rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t) - menuAttach m w 0 1 i (i+1)- return w- | (t,i)<-zip (tail aiPlayers) [1..]] - -- 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 mo ms mq mun mre mpa - msh msm mrs (zip (r:rs) (map snd aiPlayers)) opf svf cid)- -- | connect event handlers for GUI elements-connect_events gui gameRef histRef+connect_events gui gameRef = do onExpose (canvas gui) $ \x -> do drawCanvas gui gameRef return (eventSent x)@@ -161,74 +158,69 @@ do mp<-getPosition (canvas gui) (eventX x) (eventY x) case mp of Nothing -> return (eventSent x)- Just p -> do clickPosition gui gameRef histRef p+ Just p -> do clickPosition gui gameRef p return (eventSent x) onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_quit gui) mainQuit- onActivateLeaf (menu_item_new gui) $ newGame gui gameRef histRef+ onActivateLeaf (menu_item_new gui) $ newGame gui gameRef onActivateLeaf (menu_item_open gui) $ do { answer<-fileDialogRun (open_file_chooser gui) ; case answer of- Just path -> openGame gameRef histRef path+ Just path -> openGame gameRef 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")+ Just path -> saveGame gameRef (replaceExtension path ".tza") Nothing -> return () }- onActivateLeaf (menu_item_undo gui) $ moveUndo gameRef histRef- onActivateLeaf (menu_item_redo gui) $ moveRedo gameRef histRef+ onActivateLeaf (menu_item_undo gui) $ moveUndo gameRef + onActivateLeaf (menu_item_redo gui) $ moveRedo gameRef - onActivateLeaf (menu_item_pass gui) (movePass gui gameRef histRef)+ onActivateLeaf (menu_item_pass gui) (movePass gui gameRef) 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- 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 }+ Var.watch gameRef $ \gh -> + do { updateWidgets gui gh+ ; redrawCanvas (canvas gui)+ } -- | start a new game-newGame :: GUI -> GameRef -> HistRef -> IO ()-newGame gui gameRef histRef+newGame :: GUI -> GameRef -> IO ()+newGame gui gameRef = 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)+ Var.set gameRef (initGame b, History.init $ initGame b) -- | open a saved game-openGame :: GameRef -> HistRef -> FilePath -> IO ()-openGame gameRef histRef filepath+openGame :: GameRef -> FilePath -> IO ()+openGame gameRef 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)+ ((gh,_): _) -> Var.set gameRef gh + _ -> putStrLn ("WARNING: couldn't parse game file " ++ show filepath) -- | write a game file-saveGame :: GameRef -> HistRef -> FilePath -> IO ()-saveGame gameRef histRef filepath +saveGame :: GameRef -> FilePath -> IO ()+saveGame gameRef filepath = withFile filepath WriteMode $ \handle -> - do g<-Var.get gameRef - h<-Var.get histRef - hPrint handle (g,h)+ Var.get gameRef >>= hPrint handle fileDialogRun :: FileChooserDialog -> IO (Maybe FilePath)-fileDialogRun w = do {dialogRun w ; widgetHide w; fileChooserGetFilename w}-+fileDialogRun w = do { r<-dialogRun w + ; widgetHide w+ ; case r of + ResponseOk -> fileChooserGetFilename w+ _ -> return Nothing+ } -- | get the selected AI player@@ -248,8 +240,8 @@ -- | update widgets sensitivity -updateWidgets :: GUI -> Game -> History Game -> IO ()-updateWidgets gui g h+updateWidgets :: GUI -> GameHist -> IO ()+updateWidgets gui (g,h) = do { widgetSetSensitive (menu_item_undo gui) $ s/=Wait2 && not (History.atStart h) ; widgetSetSensitive (menu_item_redo gui) $@@ -281,55 +273,53 @@ -- | pass the 2nd move of a turn-movePass :: GUI -> GameRef -> HistRef -> IO ()-movePass gui gameRef histRef- = do g <- Var.get gameRef+movePass :: GUI -> GameRef -> IO ()+movePass gui gameRef + = do (g,h) <- Var.get gameRef let b = board g case state g of Wait0 | move b==2 -> - dispatch gui gameRef histRef (makeMove Pass g)+ dispatch gui gameRef (makeMove Pass g) h _ -> return () -moveUndo :: GameRef -> HistRef -> IO ()-moveUndo gameRef histRef - = do h <- Var.get histRef+moveUndo :: GameRef -> IO ()+moveUndo gameRef + = do (_,h) <- Var.get gameRef when (not $ History.atStart h) $- do Var.set histRef (History.previous h)- Var.set gameRef (History.get $ History.previous h)+ let h' = History.previous h+ in Var.set gameRef (History.get h', h') -moveRedo :: GameRef -> HistRef -> IO ()-moveRedo gameRef histRef - = do h <- Var.get histRef+moveRedo :: GameRef -> IO ()+moveRedo gameRef + = do (_,h) <- Var.get gameRef when (not $ History.atEnd h) $- do Var.set histRef (History.next h)- Var.set gameRef (History.get $ History.next h)+ let h' = History.next h+ in Var.set gameRef (History.get h', h') -- | handle a button click on a board position-clickPosition :: GUI -> GameRef -> HistRef -> Position -> IO ()-clickPosition gui gameRef histRef p- = do g <- Var.get gameRef+clickPosition :: GUI -> GameRef -> Position -> IO ()+clickPosition gui gameRef p+ = do (g,h) <- Var.get gameRef let moves = nextMoves (board g) case state g of Start0 | p`startMove`moves -> - Var.set gameRef $ g {state=Start1 p}+ Var.set gameRef (g {state=Start1 p}, h) Start1 p' | p'==p -> - Var.set gameRef $ g {state=Start0}+ Var.set gameRef (g {state=Start0}, h) Start1 p' | (Capture p' p)`elem`moves -> - dispatch gui gameRef histRef $- makeMove Pass (makeMove (Capture p' p) g)+ dispatch gui gameRef + (makeMove Pass $ makeMove (Capture p' p) g) h Wait0 | p`startMove`moves -> - Var.set gameRef $ g {state=Wait1 p, trail=[]}+ Var.set gameRef (g {state=Wait1 p, trail=[]}, h) Wait1 p' | p'==p -> - Var.set gameRef $ g {state=Wait0}+ Var.set gameRef (g {state=Wait0}, h) Wait1 p' | (Capture p' p)`elem`moves -> - dispatch gui gameRef histRef $- makeMove (Capture p' p) g+ dispatch gui gameRef (makeMove (Capture p' p) g) h Wait1 p' | (Stack p' p)`elem`moves -> - dispatch gui gameRef histRef $ - makeMove (Stack p' p) g+ dispatch gui gameRef (makeMove (Stack p' p) g) h _ -> return () @@ -340,16 +330,15 @@ notNull [p' | Stack p' _<-moves, p'==p] -- | dispatch a move -dispatch :: GUI -> GameRef -> HistRef -> Game -> IO ()-dispatch gui gameRef histRef g+dispatch :: GUI -> GameRef -> Game -> History Game -> IO ()+dispatch gui gameRef g h = 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+ Wait0 -> Var.set gameRef (g, History.record g' h)+ Finish -> Var.set gameRef (g, History.record g' h)+ Wait2 -> Var.set gameRef (g,h) >> + forkIO runAI >> + return ()+ _ -> Var.set gameRef (g,h) where g' = g { trail=[] } -- run the AI player asynchronously @@ -361,8 +350,7 @@ ; 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' + Var.set gameRef (g', History.record g' h) } makeMove :: Move -> Game -> Game@@ -391,7 +379,7 @@ b2 <- checkMenuItemGetActive (menu_item_show_moves gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui)- g <- Var.get gameRef+ (g,_) <- Var.get gameRef renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp ->
src/Main.hs view
@@ -8,23 +8,32 @@ import GUI import Tournament import Tests+import Data.List (intersperse) import System import System.Random import System.Console.GetOpt import System.Exit import Control.Monad (when)+import System.Directory+import System.FilePath data Flag = Seed Int | NumMatches Int + | DataDir FilePath | RunTests deriving Show options :: [OptDescr Flag]-options = [Option ['s'] ["seed"] (ReqArg (Seed . read) "SEED") "random number seed",- Option ['n'] ["matches"] (ReqArg (NumMatches . read) "N") "number of matches (for AI tournaments)",- Option ['T'] ["tests"] (NoArg RunTests) "run QuickCheck tests"+options = [Option ['s'] ["seed"] (ReqArg (Seed . read) "SEED") + "random number seed",+ Option ['n'] ["matches"] (ReqArg (NumMatches . read) "N") + "number of matches (for AI tournaments)",+ Option ['d'] ["dir"] (ReqArg DataDir "DATADIR")+ "data directory",+ Option ['T'] ["tests"] (NoArg RunTests) + "run QuickCheck tests" ] parseArgs :: [String] -> IO ([Flag],[String])@@ -41,27 +50,28 @@ -- default number of matches for AI tournaments-defMatches :: Int-defMatches = 10+matches :: Int+matches = 10 -processFlags :: [Flag] -> IO Int-processFlags flags = process flags defMatches+processFlags :: [Flag] -> IO ()+processFlags = mapM_ process where - process [] m = return m- process (RunTests:flags) m = run_tests >> exitSuccess- process (Seed s:flags) m = setStdGen (mkStdGen s) >> process flags m- process (NumMatches n:flags) _ = process flags n+ process RunTests = run_tests >> exitSuccess+ process (Seed s) = setStdGen (mkStdGen s) + process _ = return () main :: IO () main = do argv<-getArgs (flags, argv')<- parseArgs argv- numMatches <- processFlags flags+ processFlags flags+ dir <- getDataDir+ let numMatches = last (matches : [n | NumMatches n <- flags])+ let gladepath = last (dir : [d | DataDir d <- flags]) </> "hstzaar.glade" -- case argv' of- [] -> do gladepath <- getDataFileName "data/hstzaar.glade"- gui gladepath+ [] -> gui gladepath [a1,a2] | a1`elem`ais && a2`elem`ais-> do let numboards = max 1 (numMatches`div`2) rndgen <- getStdGen