src/GUI/Stats.hs

   1 {-# LANGUAGE BangPatterns #-}
   2
   3 module GUI.Stats (
   4     runStats,
   5 ) where
   6
   7 import Mine
   8 import GUI.Common
   9
  10 import qualified Graphics.UI.Gtk as G
  11 import System.Glib.Attributes (AttrOp (..))
  12 import Control.Monad
  13 import Control.Concurrent.MVar
  14 import Control.Concurrent
  15 import System.Random
  16 import Data.IORef
  17 import Numeric
  18
  19 data Stat = Stat !Int !Int !Int !Int
  20
  21 runStats :: Globals -> IO ()
  22 runStats g = do
  23     s <- readIORef (gState g)
  24     let strat = sStrategy s
  25         cfg   = sConfig s
  26
  27     counter <- newMVar (Stat 0 0 0 0)
  28     chunks <- newMVar 1
  29     notify <- newMVar ()
  30     thread <- forkIO $ gatherStats counter chunks notify strat cfg
  31
  32     win <- G.windowNew
  33     win `G.set` [G.windowTitle := "Statistics for " ++ sName strat]
  34
  35     vbox <- G.vBoxNew False 2
  36     win `G.containerAdd` vbox
  37
  38     hbox <- G.hBoxNew False 2
  39     vbox `G.containerAdd` hbox
  40
  41     configFrame <- G.frameNew
  42     hbox `G.containerAdd` configFrame
  43     configFrame `G.frameSetLabel` "Board"
  44
  45     configTable <- G.tableNew 3 2 False
  46     configFrame `G.containerAdd` configTable
  47     let Config { cSize = Pos sX sY, cMines = m } = sConfig s
  48     forM_ (zip3 [0..] ["width", "height", "mines"] [sX, sY, m])
  49       $ \(c, name, val) -> do
  50         label <- G.labelNew (Just name)
  51         G.miscSetAlignment label 0 0.5
  52         G.tableAttach configTable label 0 1 c (c+1) [G.Fill] [] 5 2
  53         label <- G.labelNew (Just (show val))
  54         G.miscSetAlignment label 1 0.5
  55         G.tableAttach configTable label 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2
  56
  57     statsFrame <- G.frameNew
  58     hbox `G.containerAdd` statsFrame
  59     statsFrame `G.frameSetLabel` "Statistics"
  60
  61     statsTable <- G.tableNew 3 3 False
  62     statsFrame `G.containerAdd` statsTable
  63     cs <- forM (zip [0..] ["won", "unfinished", "lost"]) $ \(c, label) -> do
  64         label <- G.labelNew (Just label)
  65         G.miscSetAlignment label 0 0.5
  66         G.tableAttach statsTable label 0 1 c (c+1) [G.Fill] [] 5 2
  67         label2 <- G.labelNew (Just "0")
  68         G.miscSetAlignment label2 1 0.5
  69         G.tableAttach statsTable label2 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2
  70         label3 <- G.labelNew (Just "0.00%")
  71         G.miscSetAlignment label3 1 0.5
  72         G.tableAttach statsTable label3 2 3 c (c+1) [G.Expand, G.Fill] [] 5 2
  73         return (label2, label3)
  74
  75     button <- G.toggleButtonNewWithLabel "Pause"
  76     vbox `G.containerAdd` button
  77     button `G.onToggled` do
  78         active <- G.toggleButtonGetActive button
  79         if active then takeMVar chunks >> return () else putMVar chunks 1
  80
  81     let update = do
  82         x <- tryTakeMVar notify
  83         case x of
  84             Just () -> do
  85                 Stat w u l t <- takeMVar counter
  86                 let total = w + u + l
  87                     d = total - t
  88                 putMVar counter (Stat w u l total)
  89                 c <- tryTakeMVar chunks
  90                 case c of
  91                     Just d' -> do
  92                         putMVar chunks (maximum [1, d' `div` 2, d `div` 2])
  93                     _  -> return ()
  94                 forM_ (zip [w, u, l] cs) $ \(c, (labelN, labelP)) -> do
  95                     labelN `G.labelSetText` show c
  96                     when (total > 0) $ do
  97                         let pct = 100 * fromIntegral c / fromIntegral total
  98                         labelP `G.labelSetText` showGFloat (Just 2) pct "%"
  99             _ -> return ()
 100         return True
 101
 102     timer <- G.timeoutAddFull update G.priorityDefaultIdle 100
 103
 104     win `G.onDestroy` do
 105         killThread thread
 106         G.timeoutRemove timer
 107
 108     G.widgetShowAll win
 109
 110 -- thread for collecting statistics
 111 gatherStats :: MVar Stat -> MVar Int ->  MVar () -> Strategy -> Config -> IO ()
 112 gatherStats counter chunks notify strategy cfg = do
 113     n <- readMVar chunks
 114     let stats :: Int -> Int -> Int -> Int -> IO Stat
 115         stats 0 !w !u !l = return (Stat w u l 0)
 116         stats i !w !u !l = do
 117             [gen1, gen2] <- replicateM 2 newStdGen
 118             let (res, _) = playGame cfg gen1 (sRun strategy gen2)
 119             case res of
 120                 Won          -> stats (i-1) (w+1) u l
 121                 Unfinished _ -> stats (i-1) w (u+1) l
 122                 Lost         -> stats (i-1) w u (l+1)
 123     Stat w u l _ <- stats n 0 0 0
 124     Stat w' u' l' t' <- takeMVar counter
 125     putMVar counter $! Stat (w + w') (u + u') (l + l') t'
 126     tryPutMVar notify ()
 127     gatherStats counter chunks notify strategy cfg