-- |
-- Module      : Main
-- 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 GeneralizedNewtypeDeriving, GADTs, BangPatterns #-}

module Main (main) where

import Mine
import Util
import GUI
import Strategies

import System.Random
import Control.Monad.State
import Control.Monad.Prompt
import Control.Concurrent
import Control.Exception
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
import Data.Char

-- state for command line processing
data MainState = MainState {
    mVerbose    :: Bool,        -- verbose flag
    mIterations :: Int,         -- number of iterations for statistics
    mStrategy   :: Strategy,    -- current strategy
    mConfig     :: Config,      -- current config (difficulty)
    mRun        :: Bool         -- has a -r option been seen?
}

-- initial state
defaultState :: MainState
defaultState = MainState {
    mVerbose = False,
    mIterations = 1,
    mStrategy = head strategies,
    mConfig = intermediate,
    mRun = True
}

-- and a state monad to wrap it
newtype Main a = Main { runMain :: StateT MainState IO a} deriving
    (Monad, MonadIO, MonadState MainState)

-- Our main function. getOpt does most of the real work.
main :: IO ()
main = do
    (acts, extra, errors) <- liftM (getOpt RequireOrder options) getArgs
    if not (null extra) || not (null errors) then do
        -- wrong arguments? -> display help.
        usage
     else if null acts then do
        -- no arguments? -> run GUI
        mainGUI'
     else do
        -- otherwise process the associated actions for the arguments in order.
        evalStateT (runMain (sequence_ acts >> defaultRun)) defaultState

options :: [OptDescr (Main ())]
options = [
    Option "s" ["strategy"] (ReqArg setStrategy "number")
        "Set the current strategy.",
    Option "l" ["list"] (NoArg listStrategies)
        "List all strategies.",
    Option "r" ["run"]  (NoArg runGame)
        "Run current strategy.",
    Option "d" ["difficulty"] (ReqArg setDiff "name")
        "Set a standard difficulty level.",
    Option "c" ["config"] (ReqArg setConfig "w:h:m")
        "Select a custom configuration.",
    Option "i" ["iterations"] (ReqArg setIterations "number")
        "Set the number of games for --run.",
    Option "" ["info"] (NoArg info)
        "Display information about current strategy.",
    Option "h" ["help"] (NoArg usage')
        "Display this help message.",
    Option "v" ["verbose"] (NoArg setVerbose)
        "Be verbose while running strategies."]

-- wrapper for mainGUI - we need to run the GUI in a bound thread, and we
-- need to wait for it to finish. this function takes care of that.
mainGUI' :: IO ()
mainGUI' = do
    finish <- newEmptyMVar
    forkOS (finally (mainGUI strategies) (putMVar finish ()))
    readMVar finish

-- list all strategies
listStrategies :: Main ()
listStrategies = liftIO $ do
    forM_ (zip [1..] strategies) $ \(n, s) -> do
         putStrLn (show n ++ ": " ++ sName s)

-- print help message
usage :: IO ()
usage = do
    putStr $ usageInfo (formatString "\
        \Usage:  mine [OPTION]...\n\
        \The options are processed in order. If no option is given, a GUI \
        \will be displayed. The following options are recognized:")
        options

-- version of usage for the `Main' monad
usage' :: Main ()
usage' = do
    liftIO usage
    modify $ \s -> s { mRun = False }

-- set strategy
-- strategies can be identified by their number (according to the list above)
-- or by their name. matching is case insensitive in the latter case.
setStrategy :: String -> Main ()
setStrategy str = case reads str of
    [(i, "")] | i > 0 && i <= length strategies -> do
        modify $ \s -> s { mStrategy = strategies !! (i-1) }
    _ -> case filter (matchStrategy str) strategies of
        [st] -> modify $ \s -> s { mStrategy = st }
        _ -> liftIO $ do
           hPutStr stderr $ "Unknown strategy '" ++ str ++ "'\n"
           exitFailure
  where
    matchStrategy name strat = map toLower name == map toLower (sName strat)

-- set number of iterations for statistics gathering
setIterations :: String -> Main ()
setIterations str = case reads str of
    [(i, "")] | i > 0 -> do
        modify $ \s -> s { mIterations = i }
    _ -> liftIO $ do
        hPutStr stderr $ "Invalid number of iterations '" ++ str ++ "'\n"
        exitFailure

-- set verbose flag
setVerbose :: Main ()
setVerbose = do
    modify $ \s -> s { mVerbose = True }

-- set difficulty level
setDiff :: String -> Main ()
setDiff str = case lookup (map toLower str) difficulties of
    Just cfg -> modify $ \s -> s { mConfig = cfg }
    Nothing -> liftIO $ do
        hPutStr stderr $ "Unknown difficulty level '" ++ str ++ "'\n"
        exitFailure
  where
    difficulties = [("beginner",     beginner),
                    ("intermediate", intermediate),
                    ("expert",       expert)]

-- set configuration
setConfig :: String -> Main ()
setConfig str = case [ Config (Pos w h) m
                     | (w, ':' : str') <- reads str,
                       (h, ':' : str'') <- reads str',
                       (m, "") <- reads str''] of
    [cfg] | validConfig cfg -> do modify $ \s -> s { mConfig = cfg }
          | otherwise -> liftIO $ do
        hPutStr stderr $ "Invalid config '" ++ str ++ "'\n"
        exitFailure
    _ -> liftIO $ do
        hPutStr stderr $ "Syntax error in config '" ++ str ++ "'\n"
        exitFailure

-- print meta-information of strategy
info :: Main ()
info = do
    strat <- gets mStrategy
    liftIO $ do
        putStrLn $ "Strategy name: " ++ sName strat
        putStrLn $ "Author       : " ++ sAuthor strat
        putStr   $ "\n" ++ formatString (sDescription strat)

-- run a game or a series of games
runGame :: Main ()
runGame = do
    verbose <- gets mVerbose
    iter    <- gets mIterations
    strat   <- gets mStrategy
    cfg     <- gets mConfig
    modify $ \s -> s { mRun = False }

    let -- play a single game
        runSingleGame :: IO (Result String)
        runSingleGame = do
            [gen1, gen2] <- replicateM 2 newStdGen
            let game = playGameP cfg gen1 (sRun strat gen2)
                handle :: Play a -> IO a
                handle Start {}    = return ()
                handle Update {}   = return ()
                -- if verbose, print trace messages with board
                handle (Trace s b)
                    | verbose   = putStrLn (show b ++ s)
                    | otherwise = return ()
            (res, brd) <- runPromptM handle game
            -- if verbose, print game result and final board
            when verbose $ putStr (show res ++ show brd)
            return res

        -- gather statistics for a series of games
        stats :: Int -> Int -> Int -> Int -> IO (Int, Int, Int)
        stats 0 !w !u !l = return (w, u, l)
        stats i !w !u !l = do
            res <- runSingleGame
            when (verbose && i > 1) $ putStrLn "-----"
            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)

    liftIO $ do
        (w, u, l) <- stats iter 0 0 0
        let summary n = show n ++ "/" ++ show (w+u+l) ++ " (" ++
                show (fromIntegral n / fromIntegral (w+u+l) * 100) ++ "%)"
        -- print statistics if more than one game was run.
        when (iter > 1) $ do
            putStrLn $ "Summary for " ++ sName strat
            putStrLn $ "  won:        " ++ summary w
            putStrLn $ "  lost:       " ++ summary l
            when (u > 0) $ putStrLn $ "  unfinished: " ++ summary u
    return ()

-- to make the -r argument optional, we call runGame by default if
-- it has not appeared.
defaultRun :: Main ()
defaultRun = do
    run <- gets mRun
    when run runGame