src/Main.hs

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