src/UI.hs

   1 {-# LANGUAGE GADTs, BangPatterns #-}
   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 System.Glib.Attributes (AttrOp (..))
  12 import Control.Monad
  13 import Control.Monad.Prompt
  14 import Data.Maybe
  15 import Data.IORef
  16 import Data.Array
  17 import System.Random
  18 import Control.Concurrent.MVar
  19 import Control.Concurrent
  20 import Numeric
  21
  22 maxSize :: Pos
  23 maxSize = Pos 30 16
  24
  25 backgroundColor :: G.Color
  26 backgroundColor = G.Color 0xE0E0 0xE0E0 0xE0E0
  27
  28 frameColor :: G.Color
  29 frameColor = G.Color 0x4040 0x4040 0x4040
  30
  31 mainUI :: [Strategy] -> IO ()
  32 mainUI strats = do
  33     G.unsafeInitGUIForThreadedRTS
  34     mkMainWindow strats
  35     G.mainGUI
  36
  37 data Globals = Globals {
  38     gBoard     :: G.DrawingArea,
  39     gStatusbar :: G.Statusbar,
  40     gState     :: IORef State
  41 }
  42
  43 data State = State {
  44     sConfig   :: Config,
  45     sStrategy :: Strategy,
  46     sBoard    :: Maybe Board,
  47     sStop     :: Maybe (IO ()),
  48     sPreviousConfigItem :: Maybe G.RadioMenuItem
  49 }
  50
  51 initState strats = State {
  52     sConfig   = beginner,
  53     sStrategy = head strats,
  54     sBoard    = Nothing,
  55     sStop     = Nothing,
  56     sPreviousConfigItem = Nothing
  57 }
  58
  59 mkMainWindow :: [Strategy] -> IO ()
  60 mkMainWindow strats = do
  61     win <- G.windowNew
  62     win `G.set` [G.windowTitle := "Haskell PGMS"]
  63     win `G.onDestroy` G.mainQuit
  64
  65     vbox <- G.vBoxNew False 0
  66     win `G.containerAdd` vbox
  67
  68     menubar <- G.menuBarNew
  69     vbox `G.containerAdd` menubar
  70
  71     board <- G.drawingAreaNew
  72     vbox `G.containerAdd` board
  73
  74     statusbar <- G.statusbarNew
  75     vbox `G.containerAdd` statusbar
  76
  77     state <- newIORef (initState strats)
  78
  79     let globals = Globals { gBoard = board,
  80                             gStatusbar = statusbar,
  81                             gState = state }
  82
  83     configureBoard globals
  84
  85     runItem <- G.menuItemNewWithLabel "Run"
  86     menubar `G.menuShellAppend` runItem
  87     runMenu <- G.menuNew
  88     runItem `G.menuItemSetSubmenu` runMenu
  89
  90     runRunItem <- G.menuItemNewWithLabel "Run"
  91     runMenu `G.menuShellAppend` runRunItem
  92     runRunItem `G.onActivateLeaf` runGame globals
  93
  94     runStatsItem <- G.menuItemNewWithLabel "Statistics..."
  95     runMenu `G.menuShellAppend` runStatsItem
  96     runStatsItem `G.onActivateLeaf` runStats globals
  97
  98     G.separatorMenuItemNew >>= G.menuShellAppend runMenu
  99
 100     runQuitItem <- G.menuItemNewWithLabel "Quit"
 101     runMenu `G.menuShellAppend` runQuitItem
 102     runQuitItem `G.onActivateLeaf` G.widgetDestroy win
 103
 104     difficultyItem <- G.menuItemNewWithLabel "Difficulty"
 105     menubar `G.menuShellAppend` difficultyItem
 106     difficultyMenu <- G.menuNew
 107     difficultyItem `G.menuItemSetSubmenu` difficultyMenu
 108     Just prev <- foldM (\prev (name, cfg) -> do
 109         item <- maybe G.radioMenuItemNewWithLabel
 110                       G.radioMenuItemNewWithLabelFromWidget
 111                       prev name
 112         item `G.onActivateLeaf` selectConfig item cfg globals
 113         difficultyMenu `G.menuShellAppend` item
 114         return (Just item)
 115         ) Nothing configs
 116     G.separatorMenuItemNew >>= G.menuShellAppend difficultyMenu
 117     customItem <- G.radioMenuItemNewWithLabelFromWidget prev "Custom..."
 118     customItem `G.onActivateLeaf` customConfig customItem globals
 119     difficultyMenu `G.menuShellAppend` customItem
 120
 121     strategyItem <- G.menuItemNewWithLabel "Strategy"
 122     menubar `G.menuShellAppend` strategyItem
 123     strategyMenu <- G.menuNew
 124     strategyItem `G.menuItemSetSubmenu` strategyMenu
 125     foldM (\prev strat -> do
 126         item <- maybe G.radioMenuItemNewWithLabel
 127                       G.radioMenuItemNewWithLabelFromWidget
 128                       prev (sName strat)
 129         strategyMenu `G.menuShellAppend` item
 130         item `G.onActivateLeaf` selectStrategy strat globals
 131         return (Just item)
 132         ) Nothing strats
 133
 134     G.widgetShowAll win
 135
 136 selectStrategy :: Strategy -> Globals -> IO ()
 137 selectStrategy strat g = do
 138     modifyIORef (gState g) $ \s -> s { sStrategy = strat }
 139     reset g
 140     G.widgetQueueDraw (gBoard g)
 141
 142 reset :: Globals -> IO ()
 143 reset g = do
 144     s <- readIORef (gState g)
 145     writeIORef (gState g) s { sBoard = Nothing, sStop = Nothing }
 146     maybe (return ()) id (sStop s)
 147
 148 configureBoard :: Globals -> IO ()
 149 configureBoard g = do
 150     let area = gBoard g
 151
 152     iconFile <- findFile "icons.png"
 153     icons <- G.pixbufNewFromFile iconFile
 154     iconSize <- G.pixbufGetWidth icons
 155     G.widgetSetSizeRequest area (pX maxSize * iconSize + 2)
 156                                 (pY maxSize * iconSize + 2)
 157
 158     area `G.onExpose` \_ -> do
 159         s <- readIORef (gState g)
 160         let board = maybe empty id (sBoard s)
 161             makeArray = listArray (Pos 1 1, cSize (sConfig s)) . repeat
 162             empty = Board {
 163                 bConfig = sConfig s,
 164                 bMines  = makeArray False,
 165                 bView   = makeArray Hidden,
 166                 bTodo   = 0 }
 167         drawBoard iconSize icons area (sConfig s) board
 168         return True
 169     return ()
 170
 171 drawBoard :: Int -> G.Pixbuf -> G.DrawingArea -> Config -> Board -> IO ()
 172 drawBoard iconSize icons area cfg board = do
 173     (w, h) <- G.widgetGetSize area
 174     let Pos sx sy = cSize cfg
 175         ox = (w - sx * iconSize) `div` 2
 176         oy = (h - sy * iconSize) `div` 2
 177     draw <- G.widgetGetDrawWindow area
 178
 179     gc <- G.gcNewWithValues draw G.newGCValues
 180     let drawCell (Pos x y) n = G.drawPixbuf draw gc icons
 181             0 (n * iconSize) (ox + (x-1)*iconSize) (oy + (y-1)*iconSize)
 182             iconSize iconSize G.RgbDitherNone 0 0
 183
 184     forM_ (assocs (bView board)) $ \(p, cell) -> case cell of
 185         Exposed n -> drawCell p n
 186         Hidden    -> drawCell p (9 + fromEnum (bMines board ! p))
 187         Marked    -> drawCell p (11 + fromEnum (bMines board ! p))
 188         Exploded  -> drawCell p 13
 189
 190     G.gcSetValues gc G.newGCValues { G.foreground = backgroundColor }
 191     G.drawRectangle draw gc False (ox - 1) (oy - 1)
 192         (sx * iconSize + 1) (sy * iconSize + 1)
 193     G.gcSetValues gc G.newGCValues { G.foreground = frameColor }
 194     G.drawRectangle draw gc False (ox - 2) (oy - 2)
 195         (sx * iconSize + 3) (sy * iconSize + 3)
 196
 197 runGame :: Globals -> IO ()
 198 runGame g = do
 199     s <- readIORef (gState g)
 200     maybe runGame' (\_ -> return False) (sStop s)
 201     return ()
 202   where
 203     runGame' :: IO Bool
 204     runGame' = do
 205         gen1 <- newStdGen
 206         gen2 <- newStdGen
 207         s <- readIORef (gState g)
 208         runPromptC finish handle (playGameP (sConfig s) gen1
 209                                       (sRun (sStrategy s) gen2))
 210
 211     handle :: Play a -> (a -> IO Bool) -> IO Bool
 212     handle (Start b) c = do
 213         msg "Start!"
 214         cont c ()
 215         setBoard b
 216     handle (Update p b) c = do
 217         cont c ()
 218         setBoard b
 219     handle (Trace s b) c = do
 220         cont c ()
 221         msg $ "Trace: " ++ s
 222         setBoard b
 223
 224     finish :: (Result String, Board) -> IO Bool
 225     finish (Won, b) = do
 226         msg "Won!"
 227         setBoard b
 228     finish (Lost, b) = do
 229         msg "Lost!"
 230         setBoard b
 231     finish (Unfinished s, b) = do
 232         msg ("Unfinished: " ++ s)
 233         setBoard b
 234
 235     cont :: (a -> IO Bool) -> a -> IO ()
 236     cont c r = do
 237         hdl <- flip G.timeoutAdd 120 $ do
 238             modifyIORef (gState g) $ \s -> s { sStop = Nothing }
 239             c r
 240         modifyIORef (gState g) $ \s -> s { sStop = Just (G.timeoutRemove hdl) }
 241
 242     setBoard :: Board -> IO Bool
 243     setBoard b = do
 244         modifyIORef (gState g) $ \s -> s { sBoard = Just b }
 245         G.widgetQueueDraw (gBoard g)
 246         return False
 247
 248     msg :: String -> IO G.MessageId
 249     msg s = do
 250         G.statusbarPush (gStatusbar g) 1 s
 251
 252 configs :: [(String, Config)]
 253 configs = [("Beginner",     beginner),
 254            ("Intermediate", intermediate),
 255            ("Expert",       expert)]
 256
 257 selectConfig :: G.RadioMenuItem -> Config -> Globals -> IO ()
 258 selectConfig item cfg g = do
 259     active <- G.checkMenuItemGetActive item
 260     if not active then do
 261         modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Just item }
 262      else do
 263         s <- readIORef (gState g)
 264         when (sConfig s /= cfg) $ do
 265             writeIORef (gState g) s { sConfig = cfg }
 266             reset g
 267             G.widgetQueueDraw (gBoard g)
 268         modifyIORef (gState g) $ \s -> s { sPreviousConfigItem = Nothing }
 269
 270 customConfig :: G.RadioMenuItem -> Globals -> IO ()
 271 customConfig item g = do
 272     active <- G.checkMenuItemGetActive item
 273     when active $ customConfig' item g
 274
 275 customConfig' :: G.RadioMenuItem -> Globals -> IO ()
 276 customConfig' item g = do
 277     s <- readIORef (gState g)
 278     let Config { cSize = Pos sx sy, cMines = m } = sConfig s
 279
 280     dia <- G.dialogNew
 281     G.dialogAddButton dia G.stockCancel G.ResponseCancel
 282     okButton <- G.dialogAddButton dia G.stockOk G.ResponseOk
 283     G.dialogSetDefaultResponse dia G.ResponseCancel
 284     G.windowSetTitle dia "Custom config"
 285
 286     upper <- G.dialogGetUpper dia
 287     table <- G.tableNew 2 3 False
 288     upper `G.containerAdd` table
 289     let fs = [("width",  2, sx, pX maxSize),
 290               ("height", 2, sy, pY maxSize),
 291               ("mines", 1, m, 999)]
 292     fields <- forM (zip [0..] fs) $ \(c, (n, l, v, h)) -> do
 293          label <- G.labelNew (Just n)
 294          G.tableAttach table label 0 1 c (c+1) [G.Fill] [] 5 2
 295          G.miscSetAlignment label 0 0.5
 296          adj <- G.adjustmentNew (fromIntegral v) l (fromIntegral h) 1 10 10
 297          button <- G.spinButtonNew adj 0.5 0
 298          G.tableAttach table button 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2
 299          return button
 300
 301     G.widgetShowAll dia
 302     res <- G.dialogRun dia
 303     [width, height, mines] <- forM fields $ \f -> do
 304          round `liftM` G.spinButtonGetValue f
 305     let cfg' = Config { cSize = Pos width height,
 306                         cMines = min (width * height - 1) mines }
 307     G.widgetDestroy dia
 308     case res of
 309         G.ResponseOk -> selectConfig item cfg' g
 310         _ -> maybe (return ()) (`G.checkMenuItemSetActive` True)
 311                    (sPreviousConfigItem s)
 312
 313 data Stat = Stat !Int !Int !Int !Int
 314
 315 runStats :: Globals -> IO ()
 316 runStats g = do
 317     s <- readIORef (gState g)
 318     let strat = sStrategy s
 319         cfg   = sConfig s
 320
 321     counter <- newMVar (Stat 0 0 0 0)
 322     chunks <- newMVar 1
 323     notify <- newMVar ()
 324     thread <- forkIO $ gatherStats counter chunks notify strat cfg
 325
 326     win <- G.windowNew
 327     win `G.set` [G.windowTitle := "Statistics for " ++ sName strat]
 328
 329     vbox <- G.vBoxNew False 2
 330     win `G.containerAdd` vbox
 331
 332     hbox <- G.hBoxNew False 2
 333     vbox `G.containerAdd` hbox
 334
 335     configFrame <- G.frameNew
 336     hbox `G.containerAdd` configFrame
 337     configFrame `G.frameSetLabel` "Board"
 338
 339     configTable <- G.tableNew 3 2 False
 340     configFrame `G.containerAdd` configTable
 341     let Config { cSize = Pos sX sY, cMines = m } = sConfig s
 342     forM_ (zip3 [0..] ["width", "height", "mines"] [sX, sY, m]) $
 343       \(c, name, val) -> do
 344         label <- G.labelNew (Just name)
 345         G.miscSetAlignment label 0 0.5
 346         G.tableAttach configTable label 0 1 c (c+1) [G.Fill] [] 5 2
 347         label <- G.labelNew (Just (show val))
 348         G.miscSetAlignment label 1 0.5
 349         G.tableAttach configTable label 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2
 350
 351     statsFrame <- G.frameNew
 352     hbox `G.containerAdd` statsFrame
 353     statsFrame `G.frameSetLabel` "Statistics"
 354
 355     statsTable <- G.tableNew 3 3 False
 356     statsFrame `G.containerAdd` statsTable
 357     cs <- forM (zip [0..] ["won", "unfinished", "lost"]) $ \(c, label) -> do
 358         label <- G.labelNew (Just label)
 359         G.miscSetAlignment label 0 0.5
 360         G.tableAttach statsTable label 0 1 c (c+1) [G.Fill] [] 5 2
 361         label2 <- G.labelNew (Just "0")
 362         G.miscSetAlignment label2 1 0.5
 363         G.tableAttach statsTable label2 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2
 364         label3 <- G.labelNew (Just "0.00%")
 365         G.miscSetAlignment label3 1 0.5
 366         G.tableAttach statsTable label3 2 3 c (c+1) [G.Expand, G.Fill] [] 5 2
 367         return (label2, label3)
 368
 369     button <- G.toggleButtonNewWithLabel "Pause"
 370     vbox `G.containerAdd` button
 371     button `G.onToggled` do
 372         active <- G.toggleButtonGetActive button
 373         if active then takeMVar chunks >> return () else putMVar chunks 1
 374
 375     let update = do
 376         x <- tryTakeMVar notify
 377         case x of
 378             Just () -> do
 379                 Stat w u l t <- takeMVar counter
 380                 let total = w + u + l
 381                     d = total - t
 382                 putMVar counter (Stat w u l total)
 383                 c <- tryTakeMVar chunks
 384                 case c of
 385                     Just d' -> do
 386                         putMVar chunks (maximum [1, d' `div` 2, d `div` 2])
 387                     _  -> return ()
 388                 forM_ (zip [w, u, l] cs) $ \(c, (labelN, labelP)) -> do
 389                     labelN `G.labelSetText` show c
 390                     when (total > 0) $ do
 391                         let pct = 100 * fromIntegral c / fromIntegral total
 392                         labelP `G.labelSetText` showGFloat (Just 2) pct "%"
 393             _ -> return ()
 394         return True
 395
 396     timer <- G.timeoutAddFull update G.priorityDefaultIdle 100
 397
 398     win `G.onDestroy` do
 399         killThread thread
 400         G.timeoutRemove timer
 401
 402     G.widgetShowAll win
 403
 404 -- thread for collecting statistics
 405 gatherStats :: MVar Stat -> MVar Int ->  MVar () -> Strategy -> Config -> IO ()
 406 gatherStats counter chunks notify strategy cfg = do
 407     n <- readMVar chunks
 408     let stats :: Int -> Int -> Int -> Int -> IO Stat
 409         stats 0 !w !u !l = return (Stat w u l 0)
 410         stats i !w !u !l = do
 411             [gen1, gen2] <- replicateM 2 newStdGen
 412             let (res, _) = playGame cfg gen1 (sRun strategy gen2)
 413             case res of
 414                 Won          -> stats (i-1) (w+1) u l
 415                 Unfinished _ -> stats (i-1) w (u+1) l
 416                 Lost         -> stats (i-1) w u (l+1)
 417     Stat w u l _ <- stats n 0 0 0
 418     Stat w' u' l' t' <- takeMVar counter
 419     putMVar counter $! Stat (w + w') (u + u') (l + l') t'
 420     tryPutMVar notify ()
 421     gatherStats counter chunks notify strategy cfg