src/GUI.hs

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