src/GUI/Stats.hs

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