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