src/GUI.hs

   1 -- |
   2 -- Module      : GUI
   3 -- Copyright   : (c) 2008 Bertram Felgenhauer
   4 -- License     : BSD3
   5 --
   6 -- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>
   7 -- Stability   : experimental
   8 -- Portability : portable
   9 --
  10 -- This module is part of Haskell PGMS.
  11 --
  12
  13 module GUI (
  14     mainGUI,
  15 ) where
  16
  17 import Mine
  18 import Util
  19 import GUI.Common
  20 import GUI.Config
  21 import GUI.Stats
  22
  23 import qualified Graphics.UI.Gtk as G
  24 import System.Glib.Attributes (AttrOp (..))
  25 import Control.Monad
  26 import Control.Monad.Prompt
  27 import Data.Maybe
  28 import Data.IORef
  29 import Data.Array.IArray
  30 import System.Random
  31
  32 backgroundColor :: G.Color
  33 backgroundColor = G.Color 0xE0E0 0xE0E0 0xE0E0
  34
  35 frameColor :: G.Color
  36 frameColor = G.Color 0x4040 0x4040 0x4040
  37
  38 mainGUI :: [Strategy] -> IO ()
  39 mainGUI strats = do
  40     G.unsafeInitGUIForThreadedRTS
  41     mkMainWindow strats
  42     G.mainGUI
  43
  44 mkMainWindow :: [Strategy] -> IO ()
  45 mkMainWindow strats = do
  46     win <- G.windowNew
  47     win `G.set` [G.windowTitle := "Haskell PGMS"]
  48     win `G.onDestroy` G.mainQuit
  49
  50     vbox <- G.vBoxNew False 0
  51     win `G.containerAdd` vbox
  52
  53     menubar <- G.menuBarNew
  54     vbox `G.containerAdd` menubar
  55
  56     board <- G.drawingAreaNew
  57     vbox `G.containerAdd` board
  58
  59     statusbar <- G.statusbarNew
  60     vbox `G.containerAdd` statusbar
  61
  62     state <- newIORef (initState strats)
  63
  64     let globals = Globals { gBoard = board,
  65                             gStatusbar = statusbar,
  66                             gState = state }
  67
  68     configureBoard globals
  69
  70     runItem <- G.menuItemNewWithLabel "Run"
  71     menubar `G.menuShellAppend` runItem
  72     runMenu <- G.menuNew
  73     runItem `G.menuItemSetSubmenu` runMenu
  74
  75     runRunItem <- G.menuItemNewWithLabel "Run"
  76     runMenu `G.menuShellAppend` runRunItem
  77     runRunItem `G.onActivateLeaf` runGame globals
  78
  79     runStatsItem <- G.menuItemNewWithLabel "Statistics..."
  80     runMenu `G.menuShellAppend` runStatsItem
  81     runStatsItem `G.onActivateLeaf` runStats globals
  82
  83     G.separatorMenuItemNew >>= G.menuShellAppend runMenu
  84
  85     runQuitItem <- G.menuItemNewWithLabel "Quit"
  86     runMenu `G.menuShellAppend` runQuitItem
  87     runQuitItem `G.onActivateLeaf` G.widgetDestroy win
  88
  89     difficultyItem <- G.menuItemNewWithLabel "Difficulty"
  90     menubar `G.menuShellAppend` difficultyItem
  91     difficultyMenu <- G.menuNew
  92     difficultyItem `G.menuItemSetSubmenu` difficultyMenu
  93     Just prev <- foldM (\prev (name, cfg) -> do
  94         item <- maybe G.radioMenuItemNewWithLabel
  95                       G.radioMenuItemNewWithLabelFromWidget
  96                       prev name
  97         item `G.onActivateLeaf` selectConfig item cfg globals
  98         difficultyMenu `G.menuShellAppend` item
  99         return (Just item)
 100         ) Nothing configs
 101     G.separatorMenuItemNew >>= G.menuShellAppend difficultyMenu
 102     customItem <- G.radioMenuItemNewWithLabelFromWidget prev "Custom..."
 103     customItem `G.onActivateLeaf` customConfig customItem globals
 104     difficultyMenu `G.menuShellAppend` customItem
 105
 106     strategyItem <- G.menuItemNewWithLabel "Strategy"
 107     menubar `G.menuShellAppend` strategyItem
 108     strategyMenu <- G.menuNew
 109     strategyItem `G.menuItemSetSubmenu` strategyMenu
 110     foldM (\prev strat -> do
 111         item <- maybe G.radioMenuItemNewWithLabel
 112                       G.radioMenuItemNewWithLabelFromWidget
 113                       prev (sName strat)
 114         strategyMenu `G.menuShellAppend` item
 115         item `G.onActivateLeaf` selectStrategy strat globals
 116         return (Just item)
 117         ) Nothing strats
 118
 119     G.widgetShowAll win
 120
 121 configureBoard :: Globals -> IO ()
 122 configureBoard g = do
 123     let area = gBoard g
 124
 125     iconFile <- findFile "icons.png"
 126     icons <- G.pixbufNewFromFile iconFile
 127     iconSize <- G.pixbufGetWidth icons
 128     G.widgetSetSizeRequest area (pX maxSize * iconSize + 2)
 129                                 (pY maxSize * iconSize + 2)
 130
 131     area `G.onExpose` \_ -> do
 132         s <- readIORef (gState g)
 133         let board = maybe empty id (sBoard s)
 134             makeArray e = listArray (Pos 1 1, cSize (sConfig s)) (repeat e)
 135             empty = Board {
 136                 bConfig = sConfig s,
 137                 bMines  = makeArray False,
 138                 bView   = makeArray Hidden,
 139                 bTodo   = 0 }
 140         drawBoard iconSize icons area (sConfig s) board
 141         return True
 142     return ()
 143
 144 drawBoard :: Int -> G.Pixbuf -> G.DrawingArea -> Config -> Board -> IO ()
 145 drawBoard iconSize icons area cfg board = do
 146     (w, h) <- G.widgetGetSize area
 147     let Pos sX sY = cSize cfg
 148         ox = (w - sX * iconSize) `div` 2
 149         oy = (h - sY * iconSize) `div` 2
 150     draw <- G.widgetGetDrawWindow area
 151
 152     gc <- G.gcNewWithValues draw G.newGCValues
 153     let drawCell (Pos x y) n = G.drawPixbuf draw gc icons
 154             0 (n * iconSize) (ox + (x-1)*iconSize) (oy + (y-1)*iconSize)
 155             iconSize iconSize G.RgbDitherNone 0 0
 156
 157     forM_ (assocs (bView board)) $ \(p, cell) -> case cell of
 158         Exposed n -> drawCell p n
 159         Hidden    -> drawCell p (9 + fromEnum (bMines board ! p))
 160         Marked    -> drawCell p (11 + fromEnum (bMines board ! p))
 161         Exploded  -> drawCell p 13
 162
 163     G.gcSetValues gc G.newGCValues { G.foreground = backgroundColor }
 164     G.drawRectangle draw gc False (ox - 1) (oy - 1)
 165         (sX * iconSize + 1) (sY * iconSize + 1)
 166     G.gcSetValues gc G.newGCValues { G.foreground = frameColor }
 167     G.drawRectangle draw gc False (ox - 2) (oy - 2)
 168         (sX * iconSize + 3) (sY * iconSize + 3)
 169
 170 runGame :: Globals -> IO ()
 171 runGame g = do
 172     s <- readIORef (gState g)
 173     maybe runGame' (\_ -> return False) (sStop s)
 174     return ()
 175   where
 176     runGame' :: IO Bool
 177     runGame' = do
 178         gen1 <- newStdGen
 179         gen2 <- newStdGen
 180         s <- readIORef (gState g)
 181         runPromptC finish handle (playGameP (sConfig s) gen1
 182                                       (sRun (sStrategy s) gen2))
 183
 184     handle :: Play a -> (a -> IO Bool) -> IO Bool
 185     handle (Start b) c = do
 186         msg "Start!"
 187         cont c ()
 188         setBoard b
 189     handle (Update p b) c = do
 190         cont c ()
 191         setBoard b
 192     handle (Trace s b) c = do
 193         cont c ()
 194         msg $ "Trace: " ++ s
 195         setBoard b
 196
 197     finish :: (Result String, Board) -> IO Bool
 198     finish (Won, b) = do
 199         msg "Won!"
 200         setBoard b
 201     finish (Lost, b) = do
 202         msg "Lost!"
 203         setBoard b
 204     finish (Unfinished s, b) = do
 205         msg ("Unfinished: " ++ s)
 206         setBoard b
 207
 208     cont :: (a -> IO Bool) -> a -> IO ()
 209     cont c r = do
 210         hdl <- flip G.timeoutAdd 120 $ do
 211             modifyIORef (gState g) $ \s -> s { sStop = Nothing }
 212             c r
 213         modifyIORef (gState g) $ \s -> s { sStop = Just (G.timeoutRemove hdl) }
 214
 215     setBoard :: Board -> IO Bool
 216     setBoard b = do
 217         modifyIORef (gState g) $ \s -> s { sBoard = Just b }
 218         G.widgetQueueDraw (gBoard g)
 219         return False
 220
 221     msg :: String -> IO G.MessageId
 222     msg s = do
 223         G.statusbarPush (gStatusbar g) 1 s