1 {-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, BangPatterns #-}
3 module Main
(main
) where
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
20 data MainState
= MainState
{
23 mStrategy
:: Strategy
,
28 defaultState
:: MainState
29 defaultState
= MainState
{
32 mStrategy
= head strategies
,
33 mConfig
= intermediate
,
37 newtype Main a
= Main
{ runMain
:: StateT MainState
IO a
} deriving
38 (Monad
, MonadIO
, MonadState MainState
)
42 finish <- newEmptyMVar
43 forkOS (finally (mainUI strategies) (putMVar finish ()))
49 (acts
, extra
, errors
) <- liftM (getOpt RequireOrder options
) getArgs
50 if not (null extra
) ||
not (null errors
) then do
52 else if null acts
then do
55 evalStateT
(runMain
(sequence_ acts
>> defaultRun
)) defaultState
57 options
:: [OptDescr
(Main
())]
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."]
78 listStrategies
:: Main
()
79 listStrategies
= liftIO
$ do
80 forM_
(zip [1..] strategies
) $ \(n
, s
) -> do
81 putStrLn (show n
++ ": " ++ sName s
)
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:")
94 modify
$ \s
-> s
{ mRun
= False }
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
}
103 hPutStr stderr $ "Unknown strategy '" ++ str
++ "'\n"
106 matchStrategy name strat
= map toLower name
== map toLower (sName strat
)
108 setIterations
:: String -> Main
()
109 setIterations str
= case reads str
of
110 [(i
, "")] | i
> 0 -> do
111 modify
$ \s
-> s
{ mIterations
= i
}
113 hPutStr stderr $ "Invalid number of iterations '" ++ str
++ "'\n"
116 setVerbose
:: Main
()
118 modify
$ \s
-> s
{ mVerbose
= True }
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"
127 difficulties
= [("beginner", beginner
),
128 ("intermediate", intermediate
),
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"
141 hPutStr stderr $ "Syntax error in config '" ++ str
++ "'\n"
146 strat
<- gets mStrategy
148 putStrLn $ "Strategy name: " ++ sName strat
149 putStrLn $ "Author : " ++ sAuthor strat
150 putStr $ "\n" ++ formatString
(sDescription strat
)
154 verbose
<- gets mVerbose
155 iter
<- gets mIterations
156 strat
<- gets mStrategy
158 modify
$ \s
-> s
{ mRun
= False }
160 let runSingleGame
:: IO (Result
String)
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 ()
168 | verbose
= putStrLn (show b
++ s
)
169 |
otherwise = return ()
170 (res
, brd
) <- runPromptM handle game
171 when verbose
$ putStr (show res
++ show brd
)
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
178 when (verbose
&& i
> 1) $ putStrLn "-----"
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)
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) ++ "%)"
189 putStrLn $ "Summary for " ++ sName strat
190 putStrLn $ " won: " ++ summary w
191 putStrLn $ " lost: " ++ summary l
192 when (u
> 0) $ putStrLn $ " unfinished: " ++ summary u
195 defaultRun
:: Main
()