From 3f8f96dcf467c8a0dd23af7f7abe72cdf5f48afa Mon Sep 17 00:00:00 2001 From: Bertram Felgenhauer Date: Thu, 15 May 2008 00:38:13 +0200 Subject: [PATCH] split GUI into several modules --- mine.cabal | 3 +- src/GUI.hs | 213 +++++++++++++++++++++++++++ src/GUI/Common.hs | 36 +++++ src/GUI/Config.hs | 86 +++++++++++ src/GUI/Stats.hs | 127 ++++++++++++++++ src/Main.hs | 10 +- src/UI.hs | 421 ------------------------------------------------------ 7 files changed, 469 insertions(+), 427 deletions(-) create mode 100644 src/GUI.hs create mode 100644 src/GUI/Common.hs create mode 100644 src/GUI/Config.hs create mode 100644 src/GUI/Stats.hs delete mode 100644 src/UI.hs diff --git a/mine.cabal b/mine.cabal index c839c56..04754aa 100644 --- a/mine.cabal +++ b/mine.cabal @@ -18,6 +18,7 @@ Data-Files: icons.png Executable mine HS-Source-Dirs: src Main-is: Main.hs - Other-Modules: Mine, SimpleStrat, Strat1, Util + Other-Modules: Mine, SimpleStrat, Strat1, Util, + GUI, GUI.Common, GUI.Config, GUI.Stats Build-Depends: base, MonadPrompt, array, mtl, random, glib, gtk, directory GHC-Options: -threaded diff --git a/src/GUI.hs b/src/GUI.hs new file mode 100644 index 0000000..342ca1c --- /dev/null +++ b/src/GUI.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE GADTs, BangPatterns #-} + +module GUI ( + mainGUI, +) where + +import Mine +import Util +import GUI.Common +import GUI.Config +import GUI.Stats + +import qualified Graphics.UI.Gtk as G +import System.Glib.Attributes (AttrOp (..)) +import Control.Monad +import Control.Monad.Prompt +import Data.Maybe +import Data.IORef +import Data.Array +import System.Random + +backgroundColor :: G.Color +backgroundColor = G.Color 0xE0E0 0xE0E0 0xE0E0 + +frameColor :: G.Color +frameColor = G.Color 0x4040 0x4040 0x4040 + +mainGUI :: [Strategy] -> IO () +mainGUI strats = do + G.unsafeInitGUIForThreadedRTS + mkMainWindow strats + G.mainGUI + +mkMainWindow :: [Strategy] -> IO () +mkMainWindow strats = do + win <- G.windowNew + win `G.set` [G.windowTitle := "Haskell PGMS"] + win `G.onDestroy` G.mainQuit + + vbox <- G.vBoxNew False 0 + win `G.containerAdd` vbox + + menubar <- G.menuBarNew + vbox `G.containerAdd` menubar + + board <- G.drawingAreaNew + vbox `G.containerAdd` board + + statusbar <- G.statusbarNew + vbox `G.containerAdd` statusbar + + state <- newIORef (initState strats) + + let globals = Globals { gBoard = board, + gStatusbar = statusbar, + gState = state } + + configureBoard globals + + runItem <- G.menuItemNewWithLabel "Run" + menubar `G.menuShellAppend` runItem + runMenu <- G.menuNew + runItem `G.menuItemSetSubmenu` runMenu + + runRunItem <- G.menuItemNewWithLabel "Run" + runMenu `G.menuShellAppend` runRunItem + runRunItem `G.onActivateLeaf` runGame globals + + runStatsItem <- G.menuItemNewWithLabel "Statistics..." + runMenu `G.menuShellAppend` runStatsItem + runStatsItem `G.onActivateLeaf` runStats globals + + G.separatorMenuItemNew >>= G.menuShellAppend runMenu + + runQuitItem <- G.menuItemNewWithLabel "Quit" + runMenu `G.menuShellAppend` runQuitItem + runQuitItem `G.onActivateLeaf` G.widgetDestroy win + + difficultyItem <- G.menuItemNewWithLabel "Difficulty" + menubar `G.menuShellAppend` difficultyItem + difficultyMenu <- G.menuNew + difficultyItem `G.menuItemSetSubmenu` difficultyMenu + Just prev <- foldM (\prev (name, cfg) -> do + item <- maybe G.radioMenuItemNewWithLabel + G.radioMenuItemNewWithLabelFromWidget + prev name + item `G.onActivateLeaf` selectConfig item cfg globals + difficultyMenu `G.menuShellAppend` item + return (Just item) + ) Nothing configs + G.separatorMenuItemNew >>= G.menuShellAppend difficultyMenu + customItem <- G.radioMenuItemNewWithLabelFromWidget prev "Custom..." + customItem `G.onActivateLeaf` customConfig customItem globals + difficultyMenu `G.menuShellAppend` customItem + + strategyItem <- G.menuItemNewWithLabel "Strategy" + menubar `G.menuShellAppend` strategyItem + strategyMenu <- G.menuNew + strategyItem `G.menuItemSetSubmenu` strategyMenu + foldM (\prev strat -> do + item <- maybe G.radioMenuItemNewWithLabel + G.radioMenuItemNewWithLabelFromWidget + prev (sName strat) + strategyMenu `G.menuShellAppend` item + item `G.onActivateLeaf` selectStrategy strat globals + return (Just item) + ) Nothing strats + + G.widgetShowAll win + +configureBoard :: Globals -> IO () +configureBoard g = do + let area = gBoard g + + iconFile <- findFile "icons.png" + icons <- G.pixbufNewFromFile iconFile + iconSize <- G.pixbufGetWidth icons + G.widgetSetSizeRequest area (pX maxSize * iconSize + 2) + (pY maxSize * iconSize + 2) + + area `G.onExpose` \_ -> do + s <- readIORef (gState g) + let board = maybe empty id (sBoard s) + makeArray = listArray (Pos 1 1, cSize (sConfig s)) . repeat + empty = Board { + bConfig = sConfig s, + bMines = makeArray False, + bView = makeArray Hidden, + bTodo = 0 } + drawBoard iconSize icons area (sConfig s) board + return True + return () + +drawBoard :: Int -> G.Pixbuf -> G.DrawingArea -> Config -> Board -> IO () +drawBoard iconSize icons area cfg board = do + (w, h) <- G.widgetGetSize area + let Pos sx sy = cSize cfg + ox = (w - sx * iconSize) `div` 2 + oy = (h - sy * iconSize) `div` 2 + draw <- G.widgetGetDrawWindow area + + gc <- G.gcNewWithValues draw G.newGCValues + let drawCell (Pos x y) n = G.drawPixbuf draw gc icons + 0 (n * iconSize) (ox + (x-1)*iconSize) (oy + (y-1)*iconSize) + iconSize iconSize G.RgbDitherNone 0 0 + + forM_ (assocs (bView board)) $ \(p, cell) -> case cell of + Exposed n -> drawCell p n + Hidden -> drawCell p (9 + fromEnum (bMines board ! p)) + Marked -> drawCell p (11 + fromEnum (bMines board ! p)) + Exploded -> drawCell p 13 + + G.gcSetValues gc G.newGCValues { G.foreground = backgroundColor } + G.drawRectangle draw gc False (ox - 1) (oy - 1) + (sx * iconSize + 1) (sy * iconSize + 1) + G.gcSetValues gc G.newGCValues { G.foreground = frameColor } + G.drawRectangle draw gc False (ox - 2) (oy - 2) + (sx * iconSize + 3) (sy * iconSize + 3) + +runGame :: Globals -> IO () +runGame g = do + s <- readIORef (gState g) + maybe runGame' (\_ -> return False) (sStop s) + return () + where + runGame' :: IO Bool + runGame' = do + gen1 <- newStdGen + gen2 <- newStdGen + s <- readIORef (gState g) + runPromptC finish handle (playGameP (sConfig s) gen1 + (sRun (sStrategy s) gen2)) + + handle :: Play a -> (a -> IO Bool) -> IO Bool + handle (Start b) c = do + msg "Start!" + cont c () + setBoard b + handle (Update p b) c = do + cont c () + setBoard b + handle (Trace s b) c = do + cont c () + msg $ "Trace: " ++ s + setBoard b + + finish :: (Result String, Board) -> IO Bool + finish (Won, b) = do + msg "Won!" + setBoard b + finish (Lost, b) = do + msg "Lost!" + setBoard b + finish (Unfinished s, b) = do + msg ("Unfinished: " ++ s) + setBoard b + + cont :: (a -> IO Bool) -> a -> IO () + cont c r = do + hdl <- flip G.timeoutAdd 120 $ do + modifyIORef (gState g) $ \s -> s { sStop = Nothing } + c r + modifyIORef (gState g) $ \s -> s { sStop = Just (G.timeoutRemove hdl) } + + setBoard :: Board -> IO Bool + setBoard b = do + modifyIORef (gState g) $ \s -> s { sBoard = Just b } + G.widgetQueueDraw (gBoard g) + return False + + msg :: String -> IO G.MessageId + msg s = do + G.statusbarPush (gStatusbar g) 1 s diff --git a/src/GUI/Common.hs b/src/GUI/Common.hs new file mode 100644 index 0000000..3372686 --- /dev/null +++ b/src/GUI/Common.hs @@ -0,0 +1,36 @@ +module GUI.Common ( + Globals (..), + State (..), + initState, + maxSize, +) where + +import Mine + +import qualified Graphics.UI.Gtk as G +import Data.IORef + +maxSize :: Pos +maxSize = Pos 30 16 + +data Globals = Globals { + gBoard :: G.DrawingArea, + gStatusbar :: G.Statusbar, + gState :: IORef State +} + +data State = State { + sConfig :: Config, + sStrategy :: Strategy, + sBoard :: Maybe Board, + sStop :: Maybe (IO ()), + sPreviousConfigItem :: Maybe G.RadioMenuItem +} + +initState strats = State { + sConfig = beginner, + sStrategy = head strats, + sBoard = Nothing, + sStop = Nothing, + sPreviousConfigItem = Nothing +} diff --git a/src/GUI/Config.hs b/src/GUI/Config.hs new file mode 100644 index 0000000..f5aecf1 --- /dev/null +++ b/src/GUI/Config.hs @@ -0,0 +1,86 @@ +module GUI.Config ( + configs, + selectStrategy, + selectConfig, + customConfig, +) where + +import Mine +import GUI.Common + +import qualified Graphics.UI.Gtk as G +import Control.Monad +import Data.IORef + +configs :: [(String, Config)] +configs = [("Beginner", beginner), + ("Intermediate", intermediate), + ("Expert", expert)] + +selectConfig :: G.RadioMenuItem -> Config -> Globals -> IO () +selectConfig item cfg g = do + active <- G.checkMenuItemGetActive item + if not active then do + modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Just item } + else do + s <- readIORef (gState g) + when (sConfig s /= cfg) $ do + writeIORef (gState g) s { sConfig = cfg } + reset g + G.widgetQueueDraw (gBoard g) + modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Nothing } + +customConfig :: G.RadioMenuItem -> Globals -> IO () +customConfig item g = do + active <- G.checkMenuItemGetActive item + when active $ customConfig' item g + +customConfig' :: G.RadioMenuItem -> Globals -> IO () +customConfig' item g = do + s <- readIORef (gState g) + let Config { cSize = Pos sx sy, cMines = m } = sConfig s + + dia <- G.dialogNew + G.dialogAddButton dia G.stockCancel G.ResponseCancel + okButton <- G.dialogAddButton dia G.stockOk G.ResponseOk + G.dialogSetDefaultResponse dia G.ResponseCancel + G.windowSetTitle dia "Custom config" + + upper <- G.dialogGetUpper dia + table <- G.tableNew 2 3 False + upper `G.containerAdd` table + let fs = [("width", 2, sx, pX maxSize), + ("height", 2, sy, pY maxSize), + ("mines", 1, m, 999)] + fields <- forM (zip [0..] fs) $ \(c, (n, l, v, h)) -> do + label <- G.labelNew (Just n) + G.tableAttach table label 0 1 c (c+1) [G.Fill] [] 5 2 + G.miscSetAlignment label 0 0.5 + adj <- G.adjustmentNew (fromIntegral v) l (fromIntegral h) 1 10 10 + button <- G.spinButtonNew adj 0.5 0 + G.tableAttach table button 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 + return button + + G.widgetShowAll dia + res <- G.dialogRun dia + [width, height, mines] <- forM fields $ \f -> do + round `liftM` G.spinButtonGetValue f + let cfg' = Config { cSize = Pos width height, + cMines = min (width * height - 1) mines } + G.widgetDestroy dia + case res of + G.ResponseOk -> selectConfig item cfg' g + _ -> maybe (return ()) (`G.checkMenuItemSetActive` True) + (sPreviousConfigItem s) + +selectStrategy :: Strategy -> Globals -> IO () +selectStrategy strat g = do + modifyIORef (gState g) $ \s -> s { sStrategy = strat } + reset g + G.widgetQueueDraw (gBoard g) + +reset :: Globals -> IO () +reset g = do + s <- readIORef (gState g) + writeIORef (gState g) s { sBoard = Nothing, sStop = Nothing } + maybe (return ()) id (sStop s) diff --git a/src/GUI/Stats.hs b/src/GUI/Stats.hs new file mode 100644 index 0000000..a21aa38 --- /dev/null +++ b/src/GUI/Stats.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns #-} + +module GUI.Stats ( + runStats, +) where + +import Mine +import GUI.Common + +import qualified Graphics.UI.Gtk as G +import System.Glib.Attributes (AttrOp (..)) +import Control.Monad +import Control.Concurrent.MVar +import Control.Concurrent +import System.Random +import Data.IORef +import Numeric + +data Stat = Stat !Int !Int !Int !Int + +runStats :: Globals -> IO () +runStats g = do + s <- readIORef (gState g) + let strat = sStrategy s + cfg = sConfig s + + counter <- newMVar (Stat 0 0 0 0) + chunks <- newMVar 1 + notify <- newMVar () + thread <- forkIO $ gatherStats counter chunks notify strat cfg + + win <- G.windowNew + win `G.set` [G.windowTitle := "Statistics for " ++ sName strat] + + vbox <- G.vBoxNew False 2 + win `G.containerAdd` vbox + + hbox <- G.hBoxNew False 2 + vbox `G.containerAdd` hbox + + configFrame <- G.frameNew + hbox `G.containerAdd` configFrame + configFrame `G.frameSetLabel` "Board" + + configTable <- G.tableNew 3 2 False + configFrame `G.containerAdd` configTable + let Config { cSize = Pos sX sY, cMines = m } = sConfig s + forM_ (zip3 [0..] ["width", "height", "mines"] [sX, sY, m]) + $ \(c, name, val) -> do + label <- G.labelNew (Just name) + G.miscSetAlignment label 0 0.5 + G.tableAttach configTable label 0 1 c (c+1) [G.Fill] [] 5 2 + label <- G.labelNew (Just (show val)) + G.miscSetAlignment label 1 0.5 + G.tableAttach configTable label 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 + + statsFrame <- G.frameNew + hbox `G.containerAdd` statsFrame + statsFrame `G.frameSetLabel` "Statistics" + + statsTable <- G.tableNew 3 3 False + statsFrame `G.containerAdd` statsTable + cs <- forM (zip [0..] ["won", "unfinished", "lost"]) $ \(c, label) -> do + label <- G.labelNew (Just label) + G.miscSetAlignment label 0 0.5 + G.tableAttach statsTable label 0 1 c (c+1) [G.Fill] [] 5 2 + label2 <- G.labelNew (Just "0") + G.miscSetAlignment label2 1 0.5 + G.tableAttach statsTable label2 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 + label3 <- G.labelNew (Just "0.00%") + G.miscSetAlignment label3 1 0.5 + G.tableAttach statsTable label3 2 3 c (c+1) [G.Expand, G.Fill] [] 5 2 + return (label2, label3) + + button <- G.toggleButtonNewWithLabel "Pause" + vbox `G.containerAdd` button + button `G.onToggled` do + active <- G.toggleButtonGetActive button + if active then takeMVar chunks >> return () else putMVar chunks 1 + + let update = do + x <- tryTakeMVar notify + case x of + Just () -> do + Stat w u l t <- takeMVar counter + let total = w + u + l + d = total - t + putMVar counter (Stat w u l total) + c <- tryTakeMVar chunks + case c of + Just d' -> do + putMVar chunks (maximum [1, d' `div` 2, d `div` 2]) + _ -> return () + forM_ (zip [w, u, l] cs) $ \(c, (labelN, labelP)) -> do + labelN `G.labelSetText` show c + when (total > 0) $ do + let pct = 100 * fromIntegral c / fromIntegral total + labelP `G.labelSetText` showGFloat (Just 2) pct "%" + _ -> return () + return True + + timer <- G.timeoutAddFull update G.priorityDefaultIdle 100 + + win `G.onDestroy` do + killThread thread + G.timeoutRemove timer + + G.widgetShowAll win + +-- thread for collecting statistics +gatherStats :: MVar Stat -> MVar Int -> MVar () -> Strategy -> Config -> IO () +gatherStats counter chunks notify strategy cfg = do + n <- readMVar chunks + let stats :: Int -> Int -> Int -> Int -> IO Stat + stats 0 !w !u !l = return (Stat w u l 0) + stats i !w !u !l = do + [gen1, gen2] <- replicateM 2 newStdGen + let (res, _) = playGame cfg gen1 (sRun strategy gen2) + case res of + Won -> stats (i-1) (w+1) u l + Unfinished _ -> stats (i-1) w (u+1) l + Lost -> stats (i-1) w u (l+1) + Stat w u l _ <- stats n 0 0 0 + Stat w' u' l' t' <- takeMVar counter + putMVar counter $! Stat (w + w') (u + u') (l + l') t' + tryPutMVar notify () + gatherStats counter chunks notify strategy cfg diff --git a/src/Main.hs b/src/Main.hs index 9714d85..1a4da70 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,7 @@ module Main (main) where import Mine import Util -import UI +import GUI import Strategies import System.Random import Control.Monad.State @@ -37,10 +37,10 @@ defaultState = MainState { newtype Main a = Main { runMain :: StateT MainState IO a} deriving (Monad, MonadIO, MonadState MainState) -mainUI' :: IO () -mainUI' = do +mainGUI' :: IO () +mainGUI' = do finish <- newEmptyMVar - forkOS (finally (mainUI strategies) (putMVar finish ())) + forkOS (finally (mainGUI strategies) (putMVar finish ())) readMVar finish main :: IO () @@ -49,7 +49,7 @@ main = do if not (null extra) || not (null errors) then do usage else if null acts then do - mainUI' + mainGUI' else do evalStateT (runMain (sequence_ acts >> defaultRun)) defaultState diff --git a/src/UI.hs b/src/UI.hs deleted file mode 100644 index c233360..0000000 --- a/src/UI.hs +++ /dev/null @@ -1,421 +0,0 @@ -{-# LANGUAGE GADTs, BangPatterns #-} - -module UI ( - mainUI, -) where - -import Mine -import Util - -import qualified Graphics.UI.Gtk as G -import System.Glib.Attributes (AttrOp (..)) -import Control.Monad -import Control.Monad.Prompt -import Data.Maybe -import Data.IORef -import Data.Array -import System.Random -import Control.Concurrent.MVar -import Control.Concurrent -import Numeric - -maxSize :: Pos -maxSize = Pos 30 16 - -backgroundColor :: G.Color -backgroundColor = G.Color 0xE0E0 0xE0E0 0xE0E0 - -frameColor :: G.Color -frameColor = G.Color 0x4040 0x4040 0x4040 - -mainUI :: [Strategy] -> IO () -mainUI strats = do - G.unsafeInitGUIForThreadedRTS - mkMainWindow strats - G.mainGUI - -data Globals = Globals { - gBoard :: G.DrawingArea, - gStatusbar :: G.Statusbar, - gState :: IORef State -} - -data State = State { - sConfig :: Config, - sStrategy :: Strategy, - sBoard :: Maybe Board, - sStop :: Maybe (IO ()), - sPreviousConfigItem :: Maybe G.RadioMenuItem -} - -initState strats = State { - sConfig = beginner, - sStrategy = head strats, - sBoard = Nothing, - sStop = Nothing, - sPreviousConfigItem = Nothing -} - -mkMainWindow :: [Strategy] -> IO () -mkMainWindow strats = do - win <- G.windowNew - win `G.set` [G.windowTitle := "Haskell PGMS"] - win `G.onDestroy` G.mainQuit - - vbox <- G.vBoxNew False 0 - win `G.containerAdd` vbox - - menubar <- G.menuBarNew - vbox `G.containerAdd` menubar - - board <- G.drawingAreaNew - vbox `G.containerAdd` board - - statusbar <- G.statusbarNew - vbox `G.containerAdd` statusbar - - state <- newIORef (initState strats) - - let globals = Globals { gBoard = board, - gStatusbar = statusbar, - gState = state } - - configureBoard globals - - runItem <- G.menuItemNewWithLabel "Run" - menubar `G.menuShellAppend` runItem - runMenu <- G.menuNew - runItem `G.menuItemSetSubmenu` runMenu - - runRunItem <- G.menuItemNewWithLabel "Run" - runMenu `G.menuShellAppend` runRunItem - runRunItem `G.onActivateLeaf` runGame globals - - runStatsItem <- G.menuItemNewWithLabel "Statistics..." - runMenu `G.menuShellAppend` runStatsItem - runStatsItem `G.onActivateLeaf` runStats globals - - G.separatorMenuItemNew >>= G.menuShellAppend runMenu - - runQuitItem <- G.menuItemNewWithLabel "Quit" - runMenu `G.menuShellAppend` runQuitItem - runQuitItem `G.onActivateLeaf` G.widgetDestroy win - - difficultyItem <- G.menuItemNewWithLabel "Difficulty" - menubar `G.menuShellAppend` difficultyItem - difficultyMenu <- G.menuNew - difficultyItem `G.menuItemSetSubmenu` difficultyMenu - Just prev <- foldM (\prev (name, cfg) -> do - item <- maybe G.radioMenuItemNewWithLabel - G.radioMenuItemNewWithLabelFromWidget - prev name - item `G.onActivateLeaf` selectConfig item cfg globals - difficultyMenu `G.menuShellAppend` item - return (Just item) - ) Nothing configs - G.separatorMenuItemNew >>= G.menuShellAppend difficultyMenu - customItem <- G.radioMenuItemNewWithLabelFromWidget prev "Custom..." - customItem `G.onActivateLeaf` customConfig customItem globals - difficultyMenu `G.menuShellAppend` customItem - - strategyItem <- G.menuItemNewWithLabel "Strategy" - menubar `G.menuShellAppend` strategyItem - strategyMenu <- G.menuNew - strategyItem `G.menuItemSetSubmenu` strategyMenu - foldM (\prev strat -> do - item <- maybe G.radioMenuItemNewWithLabel - G.radioMenuItemNewWithLabelFromWidget - prev (sName strat) - strategyMenu `G.menuShellAppend` item - item `G.onActivateLeaf` selectStrategy strat globals - return (Just item) - ) Nothing strats - - G.widgetShowAll win - -selectStrategy :: Strategy -> Globals -> IO () -selectStrategy strat g = do - modifyIORef (gState g) $ \s -> s { sStrategy = strat } - reset g - G.widgetQueueDraw (gBoard g) - -reset :: Globals -> IO () -reset g = do - s <- readIORef (gState g) - writeIORef (gState g) s { sBoard = Nothing, sStop = Nothing } - maybe (return ()) id (sStop s) - -configureBoard :: Globals -> IO () -configureBoard g = do - let area = gBoard g - - iconFile <- findFile "icons.png" - icons <- G.pixbufNewFromFile iconFile - iconSize <- G.pixbufGetWidth icons - G.widgetSetSizeRequest area (pX maxSize * iconSize + 2) - (pY maxSize * iconSize + 2) - - area `G.onExpose` \_ -> do - s <- readIORef (gState g) - let board = maybe empty id (sBoard s) - makeArray = listArray (Pos 1 1, cSize (sConfig s)) . repeat - empty = Board { - bConfig = sConfig s, - bMines = makeArray False, - bView = makeArray Hidden, - bTodo = 0 } - drawBoard iconSize icons area (sConfig s) board - return True - return () - -drawBoard :: Int -> G.Pixbuf -> G.DrawingArea -> Config -> Board -> IO () -drawBoard iconSize icons area cfg board = do - (w, h) <- G.widgetGetSize area - let Pos sx sy = cSize cfg - ox = (w - sx * iconSize) `div` 2 - oy = (h - sy * iconSize) `div` 2 - draw <- G.widgetGetDrawWindow area - - gc <- G.gcNewWithValues draw G.newGCValues - let drawCell (Pos x y) n = G.drawPixbuf draw gc icons - 0 (n * iconSize) (ox + (x-1)*iconSize) (oy + (y-1)*iconSize) - iconSize iconSize G.RgbDitherNone 0 0 - - forM_ (assocs (bView board)) $ \(p, cell) -> case cell of - Exposed n -> drawCell p n - Hidden -> drawCell p (9 + fromEnum (bMines board ! p)) - Marked -> drawCell p (11 + fromEnum (bMines board ! p)) - Exploded -> drawCell p 13 - - G.gcSetValues gc G.newGCValues { G.foreground = backgroundColor } - G.drawRectangle draw gc False (ox - 1) (oy - 1) - (sx * iconSize + 1) (sy * iconSize + 1) - G.gcSetValues gc G.newGCValues { G.foreground = frameColor } - G.drawRectangle draw gc False (ox - 2) (oy - 2) - (sx * iconSize + 3) (sy * iconSize + 3) - -runGame :: Globals -> IO () -runGame g = do - s <- readIORef (gState g) - maybe runGame' (\_ -> return False) (sStop s) - return () - where - runGame' :: IO Bool - runGame' = do - gen1 <- newStdGen - gen2 <- newStdGen - s <- readIORef (gState g) - runPromptC finish handle (playGameP (sConfig s) gen1 - (sRun (sStrategy s) gen2)) - - handle :: Play a -> (a -> IO Bool) -> IO Bool - handle (Start b) c = do - msg "Start!" - cont c () - setBoard b - handle (Update p b) c = do - cont c () - setBoard b - handle (Trace s b) c = do - cont c () - msg $ "Trace: " ++ s - setBoard b - - finish :: (Result String, Board) -> IO Bool - finish (Won, b) = do - msg "Won!" - setBoard b - finish (Lost, b) = do - msg "Lost!" - setBoard b - finish (Unfinished s, b) = do - msg ("Unfinished: " ++ s) - setBoard b - - cont :: (a -> IO Bool) -> a -> IO () - cont c r = do - hdl <- flip G.timeoutAdd 120 $ do - modifyIORef (gState g) $ \s -> s { sStop = Nothing } - c r - modifyIORef (gState g) $ \s -> s { sStop = Just (G.timeoutRemove hdl) } - - setBoard :: Board -> IO Bool - setBoard b = do - modifyIORef (gState g) $ \s -> s { sBoard = Just b } - G.widgetQueueDraw (gBoard g) - return False - - msg :: String -> IO G.MessageId - msg s = do - G.statusbarPush (gStatusbar g) 1 s - -configs :: [(String, Config)] -configs = [("Beginner", beginner), - ("Intermediate", intermediate), - ("Expert", expert)] - -selectConfig :: G.RadioMenuItem -> Config -> Globals -> IO () -selectConfig item cfg g = do - active <- G.checkMenuItemGetActive item - if not active then do - modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Just item } - else do - s <- readIORef (gState g) - when (sConfig s /= cfg) $ do - writeIORef (gState g) s { sConfig = cfg } - reset g - G.widgetQueueDraw (gBoard g) - modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Nothing } - -customConfig :: G.RadioMenuItem -> Globals -> IO () -customConfig item g = do - active <- G.checkMenuItemGetActive item - when active $ customConfig' item g - -customConfig' :: G.RadioMenuItem -> Globals -> IO () -customConfig' item g = do - s <- readIORef (gState g) - let Config { cSize = Pos sx sy, cMines = m } = sConfig s - - dia <- G.dialogNew - G.dialogAddButton dia G.stockCancel G.ResponseCancel - okButton <- G.dialogAddButton dia G.stockOk G.ResponseOk - G.dialogSetDefaultResponse dia G.ResponseCancel - G.windowSetTitle dia "Custom config" - - upper <- G.dialogGetUpper dia - table <- G.tableNew 2 3 False - upper `G.containerAdd` table - let fs = [("width", 2, sx, pX maxSize), - ("height", 2, sy, pY maxSize), - ("mines", 1, m, 999)] - fields <- forM (zip [0..] fs) $ \(c, (n, l, v, h)) -> do - label <- G.labelNew (Just n) - G.tableAttach table label 0 1 c (c+1) [G.Fill] [] 5 2 - G.miscSetAlignment label 0 0.5 - adj <- G.adjustmentNew (fromIntegral v) l (fromIntegral h) 1 10 10 - button <- G.spinButtonNew adj 0.5 0 - G.tableAttach table button 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 - return button - - G.widgetShowAll dia - res <- G.dialogRun dia - [width, height, mines] <- forM fields $ \f -> do - round `liftM` G.spinButtonGetValue f - let cfg' = Config { cSize = Pos width height, - cMines = min (width * height - 1) mines } - G.widgetDestroy dia - case res of - G.ResponseOk -> selectConfig item cfg' g - _ -> maybe (return ()) (`G.checkMenuItemSetActive` True) - (sPreviousConfigItem s) - -data Stat = Stat !Int !Int !Int !Int - -runStats :: Globals -> IO () -runStats g = do - s <- readIORef (gState g) - let strat = sStrategy s - cfg = sConfig s - - counter <- newMVar (Stat 0 0 0 0) - chunks <- newMVar 1 - notify <- newMVar () - thread <- forkIO $ gatherStats counter chunks notify strat cfg - - win <- G.windowNew - win `G.set` [G.windowTitle := "Statistics for " ++ sName strat] - - vbox <- G.vBoxNew False 2 - win `G.containerAdd` vbox - - hbox <- G.hBoxNew False 2 - vbox `G.containerAdd` hbox - - configFrame <- G.frameNew - hbox `G.containerAdd` configFrame - configFrame `G.frameSetLabel` "Board" - - configTable <- G.tableNew 3 2 False - configFrame `G.containerAdd` configTable - let Config { cSize = Pos sX sY, cMines = m } = sConfig s - forM_ (zip3 [0..] ["width", "height", "mines"] [sX, sY, m]) $ - \(c, name, val) -> do - label <- G.labelNew (Just name) - G.miscSetAlignment label 0 0.5 - G.tableAttach configTable label 0 1 c (c+1) [G.Fill] [] 5 2 - label <- G.labelNew (Just (show val)) - G.miscSetAlignment label 1 0.5 - G.tableAttach configTable label 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 - - statsFrame <- G.frameNew - hbox `G.containerAdd` statsFrame - statsFrame `G.frameSetLabel` "Statistics" - - statsTable <- G.tableNew 3 3 False - statsFrame `G.containerAdd` statsTable - cs <- forM (zip [0..] ["won", "unfinished", "lost"]) $ \(c, label) -> do - label <- G.labelNew (Just label) - G.miscSetAlignment label 0 0.5 - G.tableAttach statsTable label 0 1 c (c+1) [G.Fill] [] 5 2 - label2 <- G.labelNew (Just "0") - G.miscSetAlignment label2 1 0.5 - G.tableAttach statsTable label2 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2 - label3 <- G.labelNew (Just "0.00%") - G.miscSetAlignment label3 1 0.5 - G.tableAttach statsTable label3 2 3 c (c+1) [G.Expand, G.Fill] [] 5 2 - return (label2, label3) - - button <- G.toggleButtonNewWithLabel "Pause" - vbox `G.containerAdd` button - button `G.onToggled` do - active <- G.toggleButtonGetActive button - if active then takeMVar chunks >> return () else putMVar chunks 1 - - let update = do - x <- tryTakeMVar notify - case x of - Just () -> do - Stat w u l t <- takeMVar counter - let total = w + u + l - d = total - t - putMVar counter (Stat w u l total) - c <- tryTakeMVar chunks - case c of - Just d' -> do - putMVar chunks (maximum [1, d' `div` 2, d `div` 2]) - _ -> return () - forM_ (zip [w, u, l] cs) $ \(c, (labelN, labelP)) -> do - labelN `G.labelSetText` show c - when (total > 0) $ do - let pct = 100 * fromIntegral c / fromIntegral total - labelP `G.labelSetText` showGFloat (Just 2) pct "%" - _ -> return () - return True - - timer <- G.timeoutAddFull update G.priorityDefaultIdle 100 - - win `G.onDestroy` do - killThread thread - G.timeoutRemove timer - - G.widgetShowAll win - --- thread for collecting statistics -gatherStats :: MVar Stat -> MVar Int -> MVar () -> Strategy -> Config -> IO () -gatherStats counter chunks notify strategy cfg = do - n <- readMVar chunks - let stats :: Int -> Int -> Int -> Int -> IO Stat - stats 0 !w !u !l = return (Stat w u l 0) - stats i !w !u !l = do - [gen1, gen2] <- replicateM 2 newStdGen - let (res, _) = playGame cfg gen1 (sRun strategy gen2) - case res of - Won -> stats (i-1) (w+1) u l - Unfinished _ -> stats (i-1) w (u+1) l - Lost -> stats (i-1) w u (l+1) - Stat w u l _ <- stats n 0 0 0 - Stat w' u' l' t' <- takeMVar counter - putMVar counter $! Stat (w + w') (u + u') (l + l') t' - tryPutMVar notify () - gatherStats counter chunks notify strategy cfg -- 2.11.4.GIT