Stats.hs

-- |
-- Module      : GUI.Stats
-- Copyright   : (c) 2008 Bertram Felgenhauer
-- License     : BSD3
--
-- Maintainer  : Bertram Felgenhauer <int-e@gmx.de>
-- Stability   : experimental
-- Portability : portable
--
-- This module is part of Haskell PGMS.
--
-- Statistics window. Runs a thread for gathering game statistics and displays
-- continuously updating counts.
--

{-# LANGUAGE BangPatterns #-}

module GUI.Stats (
    runStats,
) where

import Mine
import GUI.Common

import qualified Graphics.UI.Gtk as G
import System.Glib.Attributes (AttrOp (..))
import Control.Monad
import Control.Concurrent.MVar
import Control.Concurrent
import System.Random
import Data.IORef
import Numeric

data Stat = Stat !Int !Int !Int !Int

-- create window and thread for currently selected board config and strategy
runStats :: Globals -> IO ()
runStats g = do
    s <- readIORef (gState g)
    let strat = sStrategy s
        cfg   = sConfig s

    -- communication: counters for won, unfinished, lost and total games
    counter <- newMVar (Stat 0 0 0 0)
    -- the worker works in chunks of this size
    chunks <- newMVar 1
    -- the worker sets this MVar when it has new data.
    notify <- newMVar ()
    -- start worker
    thread <- forkIO $ gatherStats counter chunks notify strat cfg

    -- create window. display strategy name in the title.
    win <- G.windowNew
    win `G.set` [G.windowTitle := "Statistics for " ++ sName strat]

    vbox <- G.vBoxNew False 2
    win `G.containerAdd` vbox

    hbox <- G.hBoxNew False 2
    vbox `G.containerAdd` hbox

    -- display information about board configuration
    configFrame <- G.frameNew
    hbox `G.containerAdd` configFrame
    configFrame `G.frameSetLabel` "Board"

    configTable <- G.tableNew 3 2 False
    configFrame `G.containerAdd` configTable
    let Config { cSize = Pos sX sY, cMines = m } = sConfig s
    forM_ (zip3 [0..] ["width", "height", "mines"] [sX, sY, m])
      $ \(c, name, val) -> do
        label <- G.labelNew (Just name)
        G.miscSetAlignment label 0 0.5
        G.tableAttach configTable label 0 1 c (c+1) [G.Fill] [] 5 2
        label <- G.labelNew (Just (show val))
        G.miscSetAlignment label 1 0.5
        G.tableAttach configTable label 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2

    -- display running counts
    statsFrame <- G.frameNew
    hbox `G.containerAdd` statsFrame
    statsFrame `G.frameSetLabel` "Statistics"

    statsTable <- G.tableNew 3 3 False
    statsFrame `G.containerAdd` statsTable
    counters <- forM (zip [0..] ["won", "unfinished", "lost"])
      $ \(c, label) -> do
        label <- G.labelNew (Just label)
        G.miscSetAlignment label 0 0.5
        G.tableAttach statsTable label 0 1 c (c+1) [G.Fill] [] 5 2
        label2 <- G.labelNew (Just "0")
        G.miscSetAlignment label2 1 0.5
        G.tableAttach statsTable label2 1 2 c (c+1) [G.Expand, G.Fill] [] 5 2
        label3 <- G.labelNew (Just "0.00%")
        G.miscSetAlignment label3 1 0.5
        G.tableAttach statsTable label3 2 3 c (c+1) [G.Expand, G.Fill] [] 5 2
        return (label2, label3)

    -- provide a button for pausing the worker
    button <- G.toggleButtonNewWithLabel "Pause"
    vbox `G.containerAdd` button
    button `G.onToggled` do
        active <- G.toggleButtonGetActive button
        if active then takeMVar chunks >> return () else putMVar chunks 1

    -- callback for updating UI
    -- we can't do Gtk+ calls from the worker, so we poll the notify MVar
    let update = do
        x <- tryTakeMVar notify
        case x of
            Just () -> do
                Stat w u l t <- takeMVar counter
                let total = w + u + l
                    d = total - t
                putMVar counter (Stat w u l total)
                c <- tryTakeMVar chunks
                case c of
                    Just d' -> do
                        -- we got d updates, and the previous chunk size was d'.
                        -- set a new chunk size.
                        putMVar chunks (maximum [1, d' `div` 2, d `div` 2])
                    _  -> return ()
                -- update the labels in the statistics frame
                forM_ (zip [w, u, l] counters) $ \(c, (labelN, labelP)) -> do
                    labelN `G.labelSetText` show c
                    when (total > 0) $ do
                        let pct = 100 * fromIntegral c / fromIntegral total
                        labelP `G.labelSetText` showGFloat (Just 2) pct "%"
            _ -> return ()
        return True

    timer <- G.timeoutAddFull update G.priorityDefaultIdle 100

    -- don't forget to clean up when the user closes the window
    win `G.onDestroy` do
        killThread thread
        G.timeoutRemove timer

    G.widgetShowAll win

-- thread for collecting statistics
gatherStats :: MVar Stat -> MVar Int ->  MVar () -> Strategy -> Config -> IO ()
gatherStats counter chunks notify strategy cfg = do
    n <- readMVar chunks
    let stats :: Int -> Int -> Int -> Int -> IO Stat
        stats 0 !w !u !l = return (Stat w u l 0)
        stats i !w !u !l = do
            [gen1, gen2] <- replicateM 2 newStdGen
            let (res, _) = playGame cfg gen1 (sRun strategy gen2)
            case res of
                Won          -> stats (i-1) (w+1) u l
                Unfinished _ -> stats (i-1) w (u+1) l
                Lost         -> stats (i-1) w u (l+1)
    Stat w u l _ <- stats n 0 0 0
    Stat w' u' l' t' <- takeMVar counter
    putMVar counter $! Stat (w + w') (u + u') (l + l') t'
    tryPutMVar notify ()
    gatherStats counter chunks notify strategy cfg