src/Main.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, BangPatterns #-}
   2
   3 module Main (main) where
   4
   5 import Mine
   6 import Util
   7 import UI
   8 import Strategies
   9 import System.Random
  10 import Control.Monad.State
  11 import Control.Monad.Prompt
  12 -- import Control.Concurrent
  13 -- import Control.Exception
  14 import System.Console.GetOpt
  15 import System.Environment
  16 import System.Exit
  17 import System.IO
  18 import Data.Char
  19
  20 data MainState = MainState {
  21     mVerbose    :: Bool,
  22     mIterations :: Int,
  23     mStrategy   :: Strategy,
  24     mConfig     :: Config,
  25     mRun        :: Bool
  26 }
  27
  28 defaultState :: MainState
  29 defaultState = MainState {
  30     mVerbose = False,
  31     mIterations = 1,
  32     mStrategy = head strategies,
  33     mConfig = intermediate,
  34     mRun = True
  35 }
  36
  37 newtype Main a = Main { runMain :: StateT MainState IO a} deriving
  38     (Monad, MonadIO, MonadState MainState)
  39
  40 {-
  41 mainUI' = do
  42     finish <- newEmptyMVar
  43     forkOS (finally (mainUI strategies) (putMVar finish ()))
  44     readMVar finish
  45 -}
  46
  47 main :: IO ()
  48 main = do
  49     (acts, extra, errors) <- liftM (getOpt RequireOrder options) getArgs
  50     if not (null extra) || not (null errors) then do
  51         usage
  52      else if null acts then do
  53         mainUI strategies
  54      else do
  55         evalStateT (runMain (sequence_ acts >> defaultRun)) defaultState
  56
  57 options :: [OptDescr (Main ())]
  58 options = [
  59     Option "s" ["strategy"] (ReqArg setStrategy "number")
  60         "Set the current strategy.",
  61     Option "l" ["list"] (NoArg listStrategies)
  62         "List all strategies.",
  63     Option "r" ["run"]  (NoArg runGame)
  64         "Run current strategy.",
  65     Option "d" ["difficulty"] (ReqArg setDiff "name")
  66         "Set a standard difficulty level.",
  67     Option "c" ["config"] (ReqArg setConfig "w:h:m")
  68         "Select a custom configuration.",
  69     Option "i" ["iterations"] (ReqArg setIterations "number")
  70         "Set the number of games for --run.",
  71     Option "" ["info"] (NoArg info)
  72         "Display information about current strategy.",
  73     Option "h" ["help"] (NoArg usage')
  74         "Display this help message.",
  75     Option "v" ["verbose"] (NoArg setVerbose)
  76         "Be verbose while running strategies."]
  77
  78 listStrategies :: Main ()
  79 listStrategies = liftIO $ do
  80     forM_ (zip [1..] strategies) $ \(n, s) -> do
  81          putStrLn (show n ++ ": " ++ sName s)
  82
  83 usage :: IO ()
  84 usage = do
  85     putStr $ usageInfo (formatString "\
  86         \Usage:  mine [OPTION]...\n\
  87         \The options are processed in order. If no option is given, a GUI \
  88         \will be displayed. The following options are recognized:")
  89         options
  90
  91 usage' :: Main ()
  92 usage' = do
  93     liftIO usage
  94     modify $ \s -> s { mRun = False }
  95
  96 setStrategy :: String -> Main ()
  97 setStrategy str = case reads str of
  98     [(i, "")] | i > 0 && i <= length strategies -> do
  99         modify $ \s -> s { mStrategy = strategies !! (i-1) }
 100     _ -> case filter (matchStrategy str) strategies of
 101         [st] -> modify $ \s -> s { mStrategy = st }
 102         _ -> liftIO $ do
 103            hPutStr stderr $ "Unknown strategy '" ++ str ++ "'\n"
 104            exitFailure
 105   where
 106     matchStrategy name strat = map toLower name == map toLower (sName strat)
 107
 108 setIterations :: String -> Main ()
 109 setIterations str = case reads str of
 110     [(i, "")] | i > 0 -> do
 111         modify $ \s -> s { mIterations = i }
 112     _ -> liftIO $ do
 113         hPutStr stderr $ "Invalid number of iterations '" ++ str ++ "'\n"
 114         exitFailure
 115
 116 setVerbose :: Main ()
 117 setVerbose = do
 118     modify $ \s -> s { mVerbose = True }
 119
 120 setDiff :: String -> Main ()
 121 setDiff str = case lookup (map toLower str) difficulties of
 122     Just cfg -> modify $ \s -> s { mConfig = cfg }
 123     Nothing -> liftIO $ do
 124         hPutStr stderr $ "Unknown difficulty level '" ++ str ++ "'\n"
 125         exitFailure
 126   where
 127     difficulties = [("beginner",     beginner),
 128                     ("intermediate", intermediate),
 129                     ("expert",       expert)]
 130
 131 setConfig :: String -> Main ()
 132 setConfig str = case [ Config (Pos w h) m
 133                      | (w, ':' : str') <- reads str,
 134                        (h, ':' : str'') <- reads str',
 135                        (m, "") <- reads str''] of
 136     [cfg] | validConfig cfg -> do modify $ \s -> s { mConfig = cfg }
 137           | otherwise -> liftIO $ do
 138         hPutStr stderr $ "Invalid config '" ++ str ++ "'\n"
 139         exitFailure
 140     _ -> liftIO $ do
 141         hPutStr stderr $ "Syntax error in config '" ++ str ++ "'\n"
 142         exitFailure
 143
 144 info :: Main ()
 145 info = do
 146     strat <- gets mStrategy
 147     liftIO $ do
 148         putStrLn $ "Strategy name: " ++ sName strat
 149         putStrLn $ "Author       : " ++ sAuthor strat
 150         putStr   $ "\n" ++ formatString (sDescription strat)
 151
 152 runGame :: Main ()
 153 runGame = do
 154     verbose <- gets mVerbose
 155     iter    <- gets mIterations
 156     strat   <- gets mStrategy
 157     cfg     <- gets mConfig
 158     modify $ \s -> s { mRun = False }
 159
 160     let runSingleGame :: IO (Result String)
 161         runSingleGame = do
 162             [gen1, gen2] <- replicateM 2 newStdGen
 163             let game = playGameP cfg gen1 (sRun strat gen2)
 164                 handle :: Play a -> IO a
 165                 handle Start {}    = return ()
 166                 handle Update {}   = return ()
 167                 handle (Trace s b)
 168                     | verbose   = putStrLn (show b ++ s)
 169                     | otherwise = return ()
 170             (res, brd) <- runPromptM handle game
 171             when verbose $ putStr (show res ++ show brd)
 172             return res
 173
 174         stats :: Int -> Int -> Int -> Int -> IO (Int, Int, Int)
 175         stats 0 !w !u !l = return (w, u, l)
 176         stats i !w !u !l = do
 177             res <- runSingleGame
 178             when (verbose && i > 1) $ putStrLn "-----"
 179             case res of
 180                 Won          -> stats (i-1) (w+1) u l
 181                 Unfinished _ -> stats (i-1) w (u+1) l
 182                 Lost         -> stats (i-1) w u (l+1)
 183
 184     liftIO $ do
 185         (w, u, l) <- stats iter 0 0 0
 186         let summary n = show n ++ "/" ++ show (w+u+l) ++ " (" ++
 187                 show (fromIntegral n / fromIntegral (w+u+l) * 100) ++ "%)"
 188         when (iter > 1) $ do
 189             putStrLn $ "Summary for " ++ sName strat
 190             putStrLn $ "  won:        " ++ summary w
 191             putStrLn $ "  lost:       " ++ summary l
 192             when (u > 0) $ putStrLn $ "  unfinished: " ++ summary u
 193     return ()
 194
 195 defaultRun :: Main ()
 196 defaultRun = do
 197     run <- gets mRun
 198     when run runGame