hs-pgms-0.1: src/GUI.hs

-- |
-- Module      : GUI
-- 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.
--

{-# LANGUAGE GADTs, BangPatterns #-}

module GUI (
    mainGUI,
) where

import Mine
import Util
import GUI.Common
import GUI.Config
import GUI.Stats

import qualified Graphics.UI.Gtk as G
import System.Glib.Attributes (AttrOp (..))
import Control.Monad
import Control.Monad.Prompt
import Data.Maybe
import Data.IORef
import Data.Array.IArray
import System.Random

backgroundColor :: G.Color
backgroundColor = G.Color 0xE0E0 0xE0E0 0xE0E0

frameColor :: G.Color
frameColor = G.Color 0x4040 0x4040 0x4040

mainGUI :: [Strategy] -> IO ()
mainGUI strats = do
    G.unsafeInitGUIForThreadedRTS
    mkMainWindow strats
    G.mainGUI

mkMainWindow :: [Strategy] -> IO ()
mkMainWindow strats = do
    win <- G.windowNew
    win `G.set` [G.windowTitle := "Haskell PGMS"]
    win `G.onDestroy` G.mainQuit

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

    menubar <- G.menuBarNew
    vbox `G.containerAdd` menubar

    board <- G.drawingAreaNew
    vbox `G.containerAdd` board

    statusbar <- G.statusbarNew
    vbox `G.containerAdd` statusbar

    state <- newIORef (initState strats)

    let globals = Globals { gBoard = board,
                            gStatusbar = statusbar,
                            gState = state }

    configureBoard globals

    runItem <- G.menuItemNewWithLabel "Run"
    menubar `G.menuShellAppend` runItem
    runMenu <- G.menuNew
    runItem `G.menuItemSetSubmenu` runMenu

    runRunItem <- G.menuItemNewWithLabel "Run"
    runMenu `G.menuShellAppend` runRunItem
    runRunItem `G.onActivateLeaf` runGame globals

    runStatsItem <- G.menuItemNewWithLabel "Statistics..."
    runMenu `G.menuShellAppend` runStatsItem
    runStatsItem `G.onActivateLeaf` runStats globals

    G.separatorMenuItemNew >>= G.menuShellAppend runMenu

    runQuitItem <- G.menuItemNewWithLabel "Quit"
    runMenu `G.menuShellAppend` runQuitItem
    runQuitItem `G.onActivateLeaf` G.widgetDestroy win

    difficultyItem <- G.menuItemNewWithLabel "Difficulty"
    menubar `G.menuShellAppend` difficultyItem
    difficultyMenu <- G.menuNew
    difficultyItem `G.menuItemSetSubmenu` difficultyMenu
    Just prev <- foldM (\prev (name, cfg) -> do
        item <- maybe G.radioMenuItemNewWithLabel
                      G.radioMenuItemNewWithLabelFromWidget
                      prev name
        item `G.onActivateLeaf` selectConfig item cfg globals
        difficultyMenu `G.menuShellAppend` item
        return (Just item)
        ) Nothing configs
    G.separatorMenuItemNew >>= G.menuShellAppend difficultyMenu
    customItem <- G.radioMenuItemNewWithLabelFromWidget prev "Custom..."
    customItem `G.onActivateLeaf` customConfig customItem globals
    difficultyMenu `G.menuShellAppend` customItem

    strategyItem <- G.menuItemNewWithLabel "Strategy"
    menubar `G.menuShellAppend` strategyItem
    strategyMenu <- G.menuNew
    strategyItem `G.menuItemSetSubmenu` strategyMenu
    foldM (\prev strat -> do
        item <- maybe G.radioMenuItemNewWithLabel
                      G.radioMenuItemNewWithLabelFromWidget
                      prev (sName strat)
        strategyMenu `G.menuShellAppend` item
        item `G.onActivateLeaf` selectStrategy strat globals
        return (Just item)
        ) Nothing strats

    G.widgetShowAll win

configureBoard :: Globals -> IO ()
configureBoard g = do
    let area = gBoard g

    iconFile <- findFile "icons.png"
    icons <- G.pixbufNewFromFile iconFile
    iconSize <- G.pixbufGetWidth icons
    G.widgetSetSizeRequest area (pX maxSize * iconSize + 2)
                                (pY maxSize * iconSize + 2)

    area `G.onExpose` \_ -> do
        s <- readIORef (gState g)
        let board = maybe empty id (sBoard s)
            makeArray e = listArray (Pos 1 1, cSize (sConfig s)) (repeat e)
            empty = Board {
                bConfig = sConfig s,
                bMines  = makeArray False,
                bView   = makeArray Hidden,
                bTodo   = 0 }
        drawBoard iconSize icons area (sConfig s) board
        return True
    return ()

drawBoard :: Int -> G.Pixbuf -> G.DrawingArea -> Config -> Board -> IO ()
drawBoard iconSize icons area cfg board = do
    (w, h) <- G.widgetGetSize area
    let Pos sX sY = cSize cfg
        ox = (w - sX * iconSize) `div` 2
        oy = (h - sY * iconSize) `div` 2
    draw <- G.widgetGetDrawWindow area

    gc <- G.gcNewWithValues draw G.newGCValues
    let drawCell (Pos x y) n = G.drawPixbuf draw gc icons
            0 (n * iconSize) (ox + (x-1)*iconSize) (oy + (y-1)*iconSize)
            iconSize iconSize G.RgbDitherNone 0 0

    forM_ (assocs (bView board)) $ \(p, cell) -> case cell of
        Exposed n -> drawCell p n
        Hidden    -> drawCell p (9 + fromEnum (bMines board ! p))
        Marked    -> drawCell p (11 + fromEnum (bMines board ! p))
        Exploded  -> drawCell p 13

    G.gcSetValues gc G.newGCValues { G.foreground = backgroundColor }
    G.drawRectangle draw gc False (ox - 1) (oy - 1)
        (sX * iconSize + 1) (sY * iconSize + 1)
    G.gcSetValues gc G.newGCValues { G.foreground = frameColor }
    G.drawRectangle draw gc False (ox - 2) (oy - 2)
        (sX * iconSize + 3) (sY * iconSize + 3)

runGame :: Globals -> IO ()
runGame g = do
    s <- readIORef (gState g)
    maybe runGame' (\_ -> return False) (sStop s)
    return ()
  where
    runGame' :: IO Bool
    runGame' = do
        gen1 <- newStdGen
        gen2 <- newStdGen
        s <- readIORef (gState g)
        runPromptC finish handle (playGameP (sConfig s) gen1
                                      (sRun (sStrategy s) gen2))

    handle :: Play a -> (a -> IO Bool) -> IO Bool
    handle (Start b) c = do
        msg "Start!"
        cont c ()
        setBoard b
    handle (Update p b) c = do
        cont c ()
        setBoard b
    handle (Trace s b) c = do
        cont c ()
        msg $ "Trace: " ++ s
        setBoard b

    finish :: (Result String, Board) -> IO Bool
    finish (Won, b) = do
        msg "Won!"
        setBoard b
    finish (Lost, b) = do
        msg "Lost!"
        setBoard b
    finish (Unfinished s, b) = do
        msg ("Unfinished: " ++ s)
        setBoard b

    cont :: (a -> IO Bool) -> a -> IO ()
    cont c r = do
        hdl <- flip G.timeoutAdd 120 $ do
            modifyIORef (gState g) $ \s -> s { sStop = Nothing }
            c r
        modifyIORef (gState g) $ \s -> s { sStop = Just (G.timeoutRemove hdl) }

    setBoard :: Board -> IO Bool
    setBoard b = do
        modifyIORef (gState g) $ \s -> s { sBoard = Just b }
        G.widgetQueueDraw (gBoard g)
        return False

    msg :: String -> IO G.MessageId
    msg s = do
        G.statusbarPush (gStatusbar g) 1 s