src/UI.hs

   1 {-# LANGUAGE GADTs #-}
   2
   3 module UI (
   4     mainUI,
   5 ) where
   6
   7 import Mine
   8 import Util
   9
  10 import qualified Graphics.UI.Gtk as G
  11 -- import qualified System.Glib as G
  12 import System.Glib.Attributes (AttrOp (..))
  13 import Control.Monad
  14 import Control.Monad.Prompt
  15 import Data.Maybe
  16 import Data.IORef
  17 import Data.Array
  18 import System.Random
  19
  20 maxSize :: Pos
  21 maxSize = Pos 30 16
  22
  23 backgroundColor :: G.Color
  24 backgroundColor = G.Color 0xE0E0 0xE0E0 0xE0E0
  25
  26 frameColor :: G.Color
  27 frameColor = G.Color 0x4040 0x4040 0x4040
  28
  29 mainUI :: [Strategy] -> IO ()
  30 mainUI strats = do
  31     G.unsafeInitGUIForThreadedRTS
  32     mkMainWindow strats
  33     G.mainGUI
  34
  35 data Globals = Globals {
  36     gBoard     :: G.DrawingArea,
  37     gStatusbar :: G.Statusbar,
  38     gState     :: IORef State
  39 }
  40
  41 data State = State {
  42     sConfig   :: Config,
  43     sStrategy :: Strategy,
  44     sBoard    :: Maybe Board,
  45     sStop     :: Maybe (IO ()),
  46     sPreviousConfigItem :: Maybe G.RadioMenuItem
  47 }
  48
  49 initState strats = State {
  50     sConfig   = beginner,
  51     sStrategy = head strats,
  52     sBoard    = Nothing,
  53     sStop     = Nothing,
  54     sPreviousConfigItem = Nothing
  55 }
  56
  57 mkMainWindow :: [Strategy] -> IO ()
  58 mkMainWindow strats = do
  59     win <- G.windowNew
  60     win `G.set` [G.windowTitle := "Haskell PGMS"]
  61     win `G.onDestroy` G.mainQuit
  62
  63     vbox <- G.vBoxNew False 0
  64     win `G.containerAdd` vbox
  65
  66     menubar <- G.menuBarNew
  67     vbox `G.containerAdd` menubar
  68
  69     board <- G.drawingAreaNew
  70     vbox `G.containerAdd` board
  71
  72     statusbar <- G.statusbarNew
  73     vbox `G.containerAdd` statusbar
  74
  75     state <- newIORef (initState strats)
  76
  77     let globals = Globals { gBoard = board,
  78                             gStatusbar = statusbar,
  79                             gState = state }
  80
  81     configureBoard globals
  82
  83     runItem <- G.menuItemNewWithLabel "Run!"
  84     menubar `G.menuShellAppend` runItem
  85
  86     runItem `G.onActivateLeaf` runGame globals
  87
  88     difficultyItem <- G.menuItemNewWithLabel "Difficulty"
  89     menubar `G.menuShellAppend` difficultyItem
  90     difficultyMenu <- G.menuNew
  91     difficultyItem `G.menuItemSetSubmenu` difficultyMenu
  92     Just prev <- foldM (\prev (name, cfg) -> do
  93         item <- maybe G.radioMenuItemNewWithLabel
  94                       G.radioMenuItemNewWithLabelFromWidget
  95                       prev name
  96         item `G.onActivateLeaf` selectConfig item cfg globals
  97         difficultyMenu `G.menuShellAppend` item
  98         return (Just item)
  99         ) Nothing configs
 100     G.separatorMenuItemNew >>= G.menuShellAppend difficultyMenu
 101     customItem <- G.radioMenuItemNewWithLabelFromWidget prev "Custom..."
 102     customItem `G.onActivateLeaf` customConfig customItem globals
 103     difficultyMenu `G.menuShellAppend` customItem
 104
 105     strategyItem <- G.menuItemNewWithLabel "Strategy"
 106     menubar `G.menuShellAppend` strategyItem
 107     strategyMenu <- G.menuNew
 108     strategyItem `G.menuItemSetSubmenu` strategyMenu
 109     foldM (\prev strat -> do
 110         item <- maybe G.radioMenuItemNewWithLabel
 111                       G.radioMenuItemNewWithLabelFromWidget
 112                       prev (sName strat)
 113         strategyMenu `G.menuShellAppend` item
 114         item `G.onActivateLeaf` selectStrategy strat globals
 115         return (Just item)
 116         ) Nothing strats
 117
 118     G.widgetShowAll win
 119
 120 selectStrategy :: Strategy -> Globals -> IO ()
 121 selectStrategy strat g = do
 122     modifyIORef (gState g) $ \s -> s { sStrategy = strat }
 123     reset g
 124     G.widgetQueueDraw (gBoard g)
 125
 126 reset :: Globals -> IO ()
 127 reset g = do
 128     s <- readIORef (gState g)
 129     writeIORef (gState g) s { sBoard = Nothing, sStop = Nothing }
 130     maybe (return ()) id (sStop s)
 131
 132 configureBoard :: Globals -> IO ()
 133 configureBoard g = do
 134     let area = gBoard g
 135
 136     iconFile <- findFile "icons.png"
 137     icons <- G.pixbufNewFromFile iconFile
 138     iconSize <- G.pixbufGetWidth icons
 139     G.widgetSetSizeRequest area (pX maxSize * iconSize + 2)
 140                                 (pY maxSize * iconSize + 2)
 141
 142     area `G.onExpose` \_ -> do
 143         s <- readIORef (gState g)
 144         let board = maybe empty id (sBoard s)
 145             makeArray = listArray (Pos 1 1, cSize (sConfig s)) . repeat
 146             empty = Board {
 147                 bConfig = sConfig s,
 148                 bMines  = makeArray False,
 149                 bView   = makeArray Hidden,
 150                 bTodo   = 0 }
 151         drawBoard iconSize icons area (sConfig s) board
 152         return True
 153     return ()
 154
 155 drawBoard :: Int -> G.Pixbuf -> G.DrawingArea -> Config -> Board -> IO ()
 156 drawBoard iconSize icons area cfg board = do
 157     (w, h) <- G.widgetGetSize area
 158     let Pos sx sy = cSize cfg
 159         ox = (w - sx * iconSize) `div` 2
 160         oy = (h - sy * iconSize) `div` 2
 161     draw <- G.widgetGetDrawWindow area
 162
 163     gc <- G.gcNewWithValues draw G.newGCValues
 164     let drawCell (Pos x y) n = G.drawPixbuf draw gc icons
 165             0 (n * iconSize) (ox + (x-1)*iconSize) (oy + (y-1)*iconSize)
 166             iconSize iconSize G.RgbDitherNone 0 0
 167
 168     forM_ (assocs (bView board)) $ \(p, cell) -> case cell of
 169         Exposed n -> drawCell p n
 170         Hidden    -> drawCell p (9 + fromEnum (bMines board ! p))
 171         Marked    -> drawCell p (11 + fromEnum (bMines board ! p))
 172         Exploded  -> drawCell p 13
 173
 174     G.gcSetValues gc G.newGCValues { G.foreground = backgroundColor }
 175     G.drawRectangle draw gc False (ox - 1) (oy - 1)
 176         (sx * iconSize + 1) (sy * iconSize + 1)
 177     G.gcSetValues gc G.newGCValues { G.foreground = frameColor }
 178     G.drawRectangle draw gc False (ox - 2) (oy - 2)
 179         (sx * iconSize + 3) (sy * iconSize + 3)
 180
 181 runGame :: Globals -> IO ()
 182 runGame g = do
 183     s <- readIORef (gState g)
 184     maybe runGame' (\_ -> return False) (sStop s)
 185     return ()
 186   where
 187     runGame' :: IO Bool
 188     runGame' = do
 189         gen1 <- newStdGen
 190         gen2 <- newStdGen
 191         s <- readIORef (gState g)
 192         runPromptC finish handle (playGameP (sConfig s) gen1
 193                                       (sRun (sStrategy s) gen2))
 194
 195     handle :: Play a -> (a -> IO Bool) -> IO Bool
 196     handle (Start b) c = do
 197         msg "Start!"
 198         cont c ()
 199         setBoard b
 200     handle (Update p b) c = do
 201         cont c ()
 202         setBoard b
 203     handle (Trace s b) c = do
 204         cont c ()
 205         msg $ "Trace: " ++ s
 206         setBoard b
 207
 208     finish :: (Result String, Board) -> IO Bool
 209     finish (Won, b) = do
 210         msg "Won!"
 211         setBoard b
 212     finish (Lost, b) = do
 213         msg "Lost!"
 214         setBoard b
 215     finish (Unfinished s, b) = do
 216         msg ("Unfinished: " ++ s)
 217         setBoard b
 218
 219     cont :: (a -> IO Bool) -> a -> IO ()
 220     cont c r = do
 221         hdl <- flip G.timeoutAdd 120 $ do
 222             modifyIORef (gState g) $ \s -> s { sStop = Nothing }
 223             c r
 224         modifyIORef (gState g) $ \s -> s { sStop = Just (G.timeoutRemove hdl) }
 225
 226     setBoard :: Board -> IO Bool
 227     setBoard b = do
 228         modifyIORef (gState g) $ \s -> s { sBoard = Just b }
 229         G.widgetQueueDraw (gBoard g)
 230         return False
 231
 232     msg :: String -> IO G.MessageId
 233     msg s = do
 234         G.statusbarPush (gStatusbar g) 1 s
 235
 236 configs :: [(String, Config)]
 237 configs = [("Beginner",     beginner),
 238            ("Intermediate", intermediate),
 239            ("Expert",       expert)]
 240
 241 selectConfig :: G.RadioMenuItem -> Config -> Globals -> IO ()
 242 selectConfig item cfg g = do
 243     active <- G.checkMenuItemGetActive item
 244     if not active then do
 245         modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Just item }
 246      else do
 247         s <- readIORef (gState g)
 248         when (sConfig s /= cfg) $ do
 249             writeIORef (gState g) s { sConfig = cfg }
 250             reset g
 251             G.widgetQueueDraw (gBoard g)
 252         modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Nothing }
 253
 254 customConfig :: G.RadioMenuItem -> Globals -> IO ()
 255 customConfig item g = do
 256     active <- G.checkMenuItemGetActive item
 257     when active $ customConfig' item g
 258
 259 customConfig' :: G.RadioMenuItem -> Globals -> IO ()
 260 customConfig' item g = do
 261     s <- readIORef (gState g)
 262     let Config { cSize = Pos sx sy, cMines = m } = sConfig s
 263
 264     dia <- G.dialogNew
 265     G.dialogAddButton dia G.stockCancel G.ResponseCancel
 266     okButton <- G.dialogAddButton dia G.stockOk G.ResponseOk
 267     G.dialogSetDefaultResponse dia G.ResponseCancel
 268     G.windowSetTitle dia "Custom config"
 269
 270     upper <- G.dialogGetUpper dia
 271     table <- G.tableNew 2 3 False
 272     upper `G.containerAdd` table
 273     let fs = [("width",  2, sx, pX maxSize),
 274               ("height", 2, sy, pY maxSize),
 275               ("mines", 1, m, 999)]
 276     fields <- forM (zip [0..] fs) $ \(c, (n, l, v, h)) -> do
 277          label <- G.labelNew (Just n)
 278          G.tableAttach table label 0 1 c (c+1) [G.Fill] [] 5 2
 279          G.miscSetAlignment label 0 0.5
 280          adj <- G.adjustmentNew (fromIntegral v) l (fromIntegral h) 1 10 10
 281          button <- G.spinButtonNew adj 0.5 0
 282          G.tableAttach table button 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2
 283          return button
 284
 285     G.widgetShowAll dia
 286     res <- G.dialogRun dia
 287     [width, height, mines] <- forM fields $ \f -> do
 288          round `liftM` G.spinButtonGetValue f
 289     let cfg' = Config { cSize = Pos width height,
 290                         cMines = min (width * height - 1) mines }
 291     G.widgetDestroy dia
 292     case res of
 293         G.ResponseOk -> selectConfig item cfg' g
 294         _ -> maybe (return ()) (`G.checkMenuItemSetActive` True)
 295                    (sPreviousConfigItem s)