From 0c0b996b715c49e9b47f4a429838a5b37ea91d2e Mon Sep 17 00:00:00 2001 From: Bertram Felgenhauer Date: Sun, 11 May 2008 21:34:46 +0200 Subject: [PATCH] implement a fairly rich command line interface --- src/Main.hs | 243 +++++++++++++++++++++++++++++++++++++++++++++++----------- src/Mine.hs | 14 ++-- src/Strat1.hs | 2 +- src/Util.hs | 17 +++- 4 files changed, 224 insertions(+), 52 deletions(-) rewrite src/Main.hs (75%) diff --git a/src/Main.hs b/src/Main.hs dissimilarity index 75% index 11f051d..aa463bd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,45 +1,198 @@ -module Main (main) where - -import UI -import Mine -import Strategies -import System.Random -import Control.Monad -import Control.Concurrent -import Control.Exception - -nGames :: Int -nGames = 10000 - -config :: Config -config = intermediate - -strategy :: Strategy -strategy = simpleStrat - -singleGame :: Bool -> Int -> IO Int -singleGame verbose n = do - gen <- newStdGen - gen2 <- newStdGen - let (res, brd) = playGame config gen (sRun strategy gen2) - when verbose $ putStr (show res ++ show brd) - if res == Won then return $! (n+1) else return n - -summary :: Int -> IO () -summary i = do - putStrLn ("Won " ++ show i ++ "/" ++ show nGames ++ " games") - -mainSingle :: IO () -mainSingle = do - singleGame True 0 - singleGame True 0 - foldM (\n _ -> singleGame False n) 0 (replicate nGames ()) >>= summary - -mainUI' = do - finish <- newEmptyMVar - forkOS (finally (mainUI strategies) (putMVar finish ())) - readMVar finish - -main :: IO () -main = do - mainUI strategies +{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} + +module Main (main) where + +import Mine +import Util +import UI +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 + +data MainState = MainState { + mVerbose :: Bool, + mIterations :: Int, + mStrategy :: Strategy, + mConfig :: Config, + mRun :: Bool +} + +defaultState :: MainState +defaultState = MainState { + mVerbose = False, + mIterations = 1, + mStrategy = head strategies, + mConfig = intermediate, + mRun = True +} + +newtype Main a = Main { runMain :: StateT MainState IO a} deriving + (Monad, MonadIO, MonadState MainState) + +{- +mainUI' = do + finish <- newEmptyMVar + forkOS (finally (mainUI strategies) (putMVar finish ())) + readMVar finish +-} + +main :: IO () +main = do + (acts, extra, errors) <- liftM (getOpt RequireOrder options) getArgs + if not (null extra) || not (null errors) then do + usage + else if null acts then do + mainUI strategies + else do + 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."] + +listStrategies :: Main () +listStrategies = liftIO $ do + forM_ (zip [1..] strategies) $ \(n, s) -> do + putStrLn (show n ++ ": " ++ sName s) + +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 + +usage' :: Main () +usage' = do + liftIO usage + modify $ \s -> s { mRun = False } + +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) + +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 + +setVerbose :: Main () +setVerbose = do + modify $ \s -> s { mVerbose = True } + +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)] + +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 + +info :: Main () +info = do + strat <- gets mStrategy + liftIO $ do + putStrLn $ "Strategy name: " ++ sName strat + putStrLn $ "Author : " ++ sAuthor strat + putStr $ "\n" ++ formatString (sDescription strat) + +runGame :: Main () +runGame = do + verbose <- gets mVerbose + iter <- gets mIterations + strat <- gets mStrategy + cfg <- gets mConfig + modify $ \s -> s { mRun = False } + + let 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 () + handle (Trace s b) + | verbose = putStrLn (show b ++ s) + | otherwise = return () + (res, brd) <- runPromptM handle game + when verbose $ putStr (show res ++ show brd) + return res + + 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) ++ "%)" + 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 () + +defaultRun :: Main () +defaultRun = do + run <- gets mRun + when run runGame diff --git a/src/Mine.hs b/src/Mine.hs index 4f3ef50..6afb0f6 100644 --- a/src/Mine.hs +++ b/src/Mine.hs @@ -2,6 +2,7 @@ module Mine ( Config (..), + validConfig, beginner, intermediate, expert, @@ -29,7 +30,6 @@ import Control.Monad.Prompt import Control.Monad.State import Data.Array import System.Random -import Debug.Trace data Pos = Pos { pX :: Int, pY :: Int } deriving (Show, Ord, Eq, Ix) @@ -64,6 +64,10 @@ data Config = Config { cMines :: Int } deriving Eq +validConfig :: Config -> Bool +validConfig Config { cSize = sz@(Pos sX sY), cMines = m } = + sX >= 2 && sY >= 2 && m >= 1 && m < sX * sY + beginner, intermediate, expert :: Config beginner = Config { cSize = Pos 9 9, cMines = 10 } intermediate = Config { cSize = Pos 16 16, cMines = 40 } @@ -71,7 +75,7 @@ expert = Config { cSize = Pos 30 16, cMines = 99 } mkBoard :: Config -> StdGen -> Board mkBoard cfg@Config { cSize = sz@(Pos sX sY), cMines = m } gen - | sX < 2 || sY < 2 || m < 1 || m >= sX * sY = error "invalid mine config" + | not (validConfig cfg) = error "invalid mine config" | otherwise = Board { bConfig = cfg, bView = listArray (Pos 1 1, sz) (repeat Hidden), @@ -180,16 +184,16 @@ playGameP cfg gen strategy = runStateT (game strategy) (mkBoard cfg gen) cont () else return Lost - handle (TraceMine s) cont = get >>= lift . prompt . Trace s >>= (cont $!) + handle (TraceMine s) cont = get >>= lift . prompt . Trace s >> cont () playGame :: Config -> StdGen -> StrategyM a -> (Result a, Board) playGame cfg gen strat = runPrompt handle (playGameP cfg gen strat) where handle :: Play a -> a handle Start {} = () handle Update {} = () - handle (Trace s b) = trace (s ++ show b) () + handle (Trace s b) = () {- example won game: -playGame beginner (mkStdGen 164806687) (mark (Pos 9 1) >> mark (Pos 3 4) >> mark (Pos 5 4) >> mark (Pos 1 5) >> mark (Pos 5 5) >> mark (Pos 9 5) >> mark (Pos 1 8) >> mark (Pos 3 8) >> mark (Pos 8 8) >> mark (Pos 3 9) >> getView >>= \l -> sequence [move p | (p, Hidden) <- assocs l]) +playGame True beginner (mkStdGen 164806687) (mark (Pos 9 1) >> mark (Pos 3 4) >> mark (Pos 5 4) >> mark (Pos 1 5) >> mark (Pos 5 5) >> mark (Pos 9 5) >> mark (Pos 1 8) >> mark (Pos 3 8) >> mark (Pos 8 8) >> mark (Pos 3 9) >> getView >>= \l -> sequence [move p | (p, Hidden) <- assocs l]) -} diff --git a/src/Strat1.hs b/src/Strat1.hs index 7874cfa..5b4bf5e 100644 --- a/src/Strat1.hs +++ b/src/Strat1.hs @@ -12,7 +12,7 @@ import System.Random strat1 :: Strategy strat1 = defaultStrategy { - sName = "Strategy One", + sName = "Strategy1", sAuthor = "Bertram Felgenhauer ", sDescription = "A first attempt at implementing the Single Point Strategy. It's \ diff --git a/src/Util.hs b/src/Util.hs index c57488b..f58b6cc 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,9 +1,12 @@ module Util ( - findFile + findFile, + formatString ) where import Paths_mine import System.Directory +import Data.Char +import Data.List findFile :: FilePath -> IO FilePath findFile name = do @@ -17,3 +20,15 @@ findFile name = do return $ "data/" ++ name, return $ "../data/" ++ name, return $ name] + +formatString :: String -> String +formatString = unlines . concatMap (block . (++" ")) . intersperse "" . lines + where + block "" = [] + block text = let + (chunk, rest) = splitAt 78 text + (end', start') = span (not . isSpace) (reverse chunk) + in + if null start' then chunk : block (dropWhile isSpace rest) + else reverse (dropWhile isSpace start') + : block (reverse end' ++ rest) -- 2.11.4.GIT