src/Main.hs

   1 -- |
   2 -- Module      : Main
   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 module Main (main) where
  14
  15 import Mine
  16 import Util
  17 import GUI
  18 import Strategies
  19
  20 import System.Random
  21 import Control.Monad.State
  22 import Control.Monad.Prompt
  23 import Control.Concurrent
  24 import Control.Exception
  25 import System.Console.GetOpt
  26 import System.Environment
  27 import System.Exit
  28 import System.IO
  29 import Data.Char
  30
  31 -- state for command line processing
  32 data MainState = MainState {
  33     mVerbose    :: Bool,        -- verbose flag
  34     mIterations :: Int,         -- number of iterations for statistics
  35     mStrategy   :: Strategy,    -- current strategy
  36     mConfig     :: Config,      -- current config (difficulty)
  37     mRun        :: Bool         -- has a -r option been seen?
  38 }
  39
  40 -- initial state
  41 defaultState :: MainState
  42 defaultState = MainState {
  43     mVerbose = False,
  44     mIterations = 1,
  45     mStrategy = head strategies,
  46     mConfig = intermediate,
  47     mRun = True
  48 }
  49
  50 -- and a state monad to wrap it
  51 newtype Main a = Main { runMain :: StateT MainState IO a} deriving
  52     (Monad, MonadIO, MonadState MainState)
  53
  54 -- Our main function. getOpt does most of the real work.
  55 main :: IO ()
  56 main = do
  57     (acts, extra, errors) <- liftM (getOpt RequireOrder options) getArgs
  58     if not (null extra) || not (null errors) then do
  59         -- wrong arguments? -> display help.
  60         usage
  61      else if null acts then do
  62         -- no arguments? -> run GUI
  63         mainGUI'
  64      else do
  65         -- otherwise process the associated actions for the arguments in order.
  66         evalStateT (runMain (sequence_ acts >> defaultRun)) defaultState
  67
  68 options :: [OptDescr (Main ())]
  69 options = [
  70     Option "s" ["strategy"] (ReqArg setStrategy "number")
  71         "Set the current strategy.",
  72     Option "l" ["list"] (NoArg listStrategies)
  73         "List all strategies.",
  74     Option "r" ["run"]  (NoArg runGame)
  75         "Run current strategy.",
  76     Option "d" ["difficulty"] (ReqArg setDiff "name")
  77         "Set a standard difficulty level.",
  78     Option "c" ["config"] (ReqArg setConfig "w:h:m")
  79         "Select a custom configuration.",
  80     Option "i" ["iterations"] (ReqArg setIterations "number")
  81         "Set the number of games for --run.",
  82     Option "" ["info"] (NoArg info)
  83         "Display information about current strategy.",
  84     Option "h" ["help"] (NoArg usage')
  85         "Display this help message.",
  86     Option "v" ["verbose"] (NoArg setVerbose)
  87         "Be verbose while running strategies."]
  88
  89 -- wrapper for mainGUI - we need to run the GUI in a bound thread, and we
  90 -- need to wait for it to finish. this function takes care of that.
  91 mainGUI' :: IO ()
  92 mainGUI' = do
  93     finish <- newEmptyMVar
  94     forkOS (finally (mainGUI strategies) (putMVar finish ()))
  95     readMVar finish
  96
  97 -- list all strategies
  98 listStrategies :: Main ()
  99 listStrategies = liftIO $ do
 100     forM_ (zip [1..] strategies) $ \(n, s) -> do
 101          putStrLn (show n ++ ": " ++ sName s)
 102
 103 -- print help message
 104 usage :: IO ()
 105 usage = do
 106     putStr $ usageInfo (formatString "\
 107         \Usage:  mine [OPTION]...\n\
 108         \The options are processed in order. If no option is given, a GUI \
 109         \will be displayed. The following options are recognized:")
 110         options
 111
 112 -- version of usage for the `Main' monad
 113 usage' :: Main ()
 114 usage' = do
 115     liftIO usage
 116     modify $ \s -> s { mRun = False }
 117
 118 -- set strategy
 119 -- strategies can be identified by their number (according to the list above)
 120 -- or by their name. matching is case insensitive in the latter case.
 121 setStrategy :: String -> Main ()
 122 setStrategy str = case reads str of
 123     [(i, "")] | i > 0 && i <= length strategies -> do
 124         modify $ \s -> s { mStrategy = strategies !! (i-1) }
 125     _ -> case filter (matchStrategy str) strategies of
 126         [st] -> modify $ \s -> s { mStrategy = st }
 127         _ -> liftIO $ do
 128            hPutStr stderr $ "Unknown strategy '" ++ str ++ "'\n"
 129            exitFailure
 130   where
 131     matchStrategy name strat = map toLower name == map toLower (sName strat)
 132
 133 -- set number of iterations for statistics gathering
 134 setIterations :: String -> Main ()
 135 setIterations str = case reads str of
 136     [(i, "")] | i > 0 -> do
 137         modify $ \s -> s { mIterations = i }
 138     _ -> liftIO $ do
 139         hPutStr stderr $ "Invalid number of iterations '" ++ str ++ "'\n"
 140         exitFailure
 141
 142 -- set verbose flag
 143 setVerbose :: Main ()
 144 setVerbose = do
 145     modify $ \s -> s { mVerbose = True }
 146
 147 -- set difficulty level
 148 setDiff :: String -> Main ()
 149 setDiff str = case lookup (map toLower str) difficulties of
 150     Just cfg -> modify $ \s -> s { mConfig = cfg }
 151     Nothing -> liftIO $ do
 152         hPutStr stderr $ "Unknown difficulty level '" ++ str ++ "'\n"
 153         exitFailure
 154   where
 155     difficulties = [("beginner",     beginner),
 156                     ("intermediate", intermediate),
 157                     ("expert",       expert)]
 158
 159 -- set configuration
 160 setConfig :: String -> Main ()
 161 setConfig str = case [ Config (Pos w h) m
 162                      | (w, ':' : str') <- reads str,
 163                        (h, ':' : str'') <- reads str',
 164                        (m, "") <- reads str''] of
 165     [cfg] | validConfig cfg -> do modify $ \s -> s { mConfig = cfg }
 166           | otherwise -> liftIO $ do
 167         hPutStr stderr $ "Invalid config '" ++ str ++ "'\n"
 168         exitFailure
 169     _ -> liftIO $ do
 170         hPutStr stderr $ "Syntax error in config '" ++ str ++ "'\n"
 171         exitFailure
 172
 173 -- print meta-information of strategy
 174 info :: Main ()
 175 info = do
 176     strat <- gets mStrategy
 177     liftIO $ do
 178         putStrLn $ "Strategy name: " ++ sName strat
 179         putStrLn $ "Author       : " ++ sAuthor strat
 180         putStr   $ "\n" ++ formatString (sDescription strat)
 181
 182 -- run a game or a series of games
 183 runGame :: Main ()
 184 runGame = do
 185     verbose <- gets mVerbose
 186     iter    <- gets mIterations
 187     strat   <- gets mStrategy
 188     cfg     <- gets mConfig
 189     modify $ \s -> s { mRun = False }
 190
 191     let -- play a single game
 192         runSingleGame :: IO (Result String)
 193         runSingleGame = do
 194             [gen1, gen2] <- replicateM 2 newStdGen
 195             let game = playGameP cfg gen1 (sRun strat gen2)
 196                 handle :: Play a -> IO a
 197                 handle Start {}    = return ()
 198                 handle Update {}   = return ()
 199                 -- if verbose, print trace messages with board
 200                 handle (Trace s b)
 201                     | verbose   = putStrLn (show b ++ s)
 202                     | otherwise = return ()
 203             (res, brd) <- runPromptM handle game
 204             -- if verbose, print game result and final board
 205             when verbose $ putStr (show res ++ show brd)
 206             return res
 207
 208         -- gather statistics for a series of games
 209         stats :: Int -> Int -> Int -> Int -> IO (Int, Int, Int)
 210         stats 0 !w !u !l = return (w, u, l)
 211         stats i !w !u !l = do
 212             res <- runSingleGame
 213             when (verbose && i > 1) $ putStrLn "-----"
 214             case res of
 215                 Won          -> stats (i-1) (w+1) u l
 216                 Unfinished _ -> stats (i-1) w (u+1) l
 217                 Lost         -> stats (i-1) w u (l+1)
 218
 219     liftIO $ do
 220         (w, u, l) <- stats iter 0 0 0
 221         let summary n = show n ++ "/" ++ show (w+u+l) ++ " (" ++
 222                 show (fromIntegral n / fromIntegral (w+u+l) * 100) ++ "%)"
 223         -- print statistics if more than one game was run.
 224         when (iter > 1) $ do
 225             putStrLn $ "Summary for " ++ sName strat
 226             putStrLn $ "  won:        " ++ summary w
 227             putStrLn $ "  lost:       " ++ summary l
 228             when (u > 0) $ putStrLn $ "  unfinished: " ++ summary u
 229     return ()
 230
 231 -- to make the -r argument optional, we call runGame by default if
 232 -- it has not appeared.
 233 defaultRun :: Main ()
 234 defaultRun = do
 235     run <- gets mRun
 236     when run runGame