src/UI.hs

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