typo fix
[hs-pgms.git] / src / Mine.hs
blob064a5982c51e7f586e1590e7d4c387ce38e5ebce
1 -- |
2 -- Module : Mine
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.
12 -- It provides types and a monad for implementing and running Minesweeper
13 -- strategies. It's the core of PGMS.
16 {-# LANGUAGE GADTs, FlexibleContexts, Rank2Types, GeneralizedNewtypeDeriving #-}
18 module Mine (
19 -- * Minesweeper configurations
20 Config (..),
21 validConfig,
22 beginner,
23 intermediate,
24 expert,
25 -- * Minesweeper boards
26 Pos (..),
27 Cell (..),
28 Board (..),
29 View,
30 neighbours,
31 -- * Minesweeper strategies
32 StrategyM,
33 Strategy (..),
34 defaultStrategy,
35 move,
36 move_,
37 mark,
38 getView,
39 getConfig,
40 traceMine,
41 -- * Running Minesweeper games
42 Result (..),
43 playGame,
44 Play (..),
45 playGameP,
46 ) where
48 import Control.Monad.Prompt
49 import Control.Monad.State
50 import Data.Array
51 import System.Random
53 -- | A point in 2D space with integer coordinates.
55 -- Used to adress cells on a Minesweeper board, and also to describe board
56 -- sizes.
57 data Pos = Pos { pX :: Int, pY :: Int } deriving (Show, Ord, Eq, Ix)
59 -- | A cell on a Minesweeper board.
60 data Cell = Hidden -- ^ a hidden cell
61 | Marked -- ^ a marked cell
62 | Exploded -- ^ oops, you stepped on a mine here!
63 | Exposed Int -- ^ an exposed cell with a count of neighbours
64 deriving (Eq, Show)
66 -- | A view of the Minesweeper board.
67 type View = Array Pos Cell
69 -- | A complete Minesweeper board, including hidden state.
70 data Board = Board {
71 bConfig :: Config, -- ^ board size etc.
72 bMines :: Array Pos Bool, -- ^ array indicating the position of the mines
73 bView :: View, -- ^ current view
74 bTodo :: Int -- ^ number of mines left to find
77 instance Show Board where
78 show Board { bConfig = Config { cSize = p }, bMines = b, bView = v } =
79 '\n' : unlines [ "|" ++ concat [cell (Pos x y) | x <- [1..pX p]] ++ " |"
80 | y <- [1..pY p]]
81 where
82 cell p | b ! p = case v ! p of
83 Hidden -> " :"
84 Marked -> " X"
85 Exploded -> ">%"
86 | otherwise = case v ! p of
87 Hidden -> " ."
88 Marked -> " !"
89 Exposed 0 -> " "
90 Exposed i -> ' ' : toEnum (48 + i) : ""
92 -- | Description of a mine sweeper configuration (or difficulty).
93 data Config = Config {
94 cSize :: Pos, -- ^ the board size
95 cMines :: Int -- ^ the number of mines placed on the board
96 } deriving (Eq, Show)
98 -- | Check validity of a config.
100 -- The width and height must be at least 2, and the number of mines must be
101 -- between 1 and the number of cells on the board, minus 1.
102 validConfig :: Config -> Bool
103 validConfig Config { cSize = sz@(Pos sX sY), cMines = m } =
104 sX >= 2 && sY >= 2 && m >= 1 && m < sX * sY
106 -- | Default config: 9x9 with 10 mines
107 beginner :: Config
108 beginner = Config { cSize = Pos 9 9, cMines = 10 }
110 -- | Default config: 16x16 with 40 mines
111 intermediate :: Config
112 intermediate = Config { cSize = Pos 16 16, cMines = 40 }
114 -- | Default config: 30x16 with 99 mines
115 expert :: Config
116 expert = Config { cSize = Pos 30 16, cMines = 99 }
118 -- Create a random board according to the given config.
119 mkBoard :: Config -> StdGen -> Board
120 mkBoard cfg@Config { cSize = sz@(Pos sX sY), cMines = m } gen
121 | not (validConfig cfg) = error "invalid mine config"
122 | otherwise = Board {
123 bConfig = cfg,
124 bView = listArray (Pos 1 1, sz) (repeat Hidden),
125 bMines = listArray (Pos 1 1, sz) (pick gen (sX * sY) m),
126 bTodo = sX * sY - m
128 where
129 pick gen n m | r <= m = True : pick gen' (n-1) (m-1)
130 | otherwise = False : pick gen' (n-1) m
131 where
132 (r, gen') = randomR (1, n) gen
134 -- | Find the neighbouring cells of a given cell.
136 -- The 'Config' parameter is used to find the boundaries of the board.
137 neighbours :: Config -> Pos -> [Pos]
138 neighbours Config { cSize = Pos sX sY } (Pos x y) =
139 [ Pos (x + dx) (y + dy)
140 | dx <- if x == 1 then [0..1] else if x == sX then [-1..0] else [-1..1],
141 dy <- if y == 1 then [0..1] else if y == sY then [-1..0] else [-1..1],
142 dx /= 0 || dy /= 0]
144 -- count the mines in the neighbourhood of the given cell
145 mines :: Board -> Pos -> Int
146 mines Board { bConfig = cfg, bMines = m } =
147 length . filter (m !) . neighbours cfg
149 data Request a where
150 Move :: Pos -> Request Int
151 Mark :: Pos -> Request ()
152 GetView :: Request View
153 GetConfig :: Request Config
154 TraceMine :: String -> Request ()
156 -- | The monad for implementing Minesweeper strategies.
157 newtype StrategyM a = StrategyM {
158 runStrategyM :: Prompt Request a
159 } deriving Monad
161 -- | Reveal a cell. Returns the number of mines in the neighbourhood.
163 -- Note: Revealing a cell with a mine beneath will lose the game.
164 move :: Pos -> StrategyM Int
165 move = StrategyM . prompt . Move
167 -- | Like 'move', but with no return value.
168 move_ :: Pos -> StrategyM ()
169 move_ = (>> return ()) . move
171 -- | Mark a cell.
173 -- Note: Marking a cell without a mine beneath will lose the game. This is
174 -- a deviation from standard Minesweeper.
175 mark :: Pos -> StrategyM ()
176 mark = StrategyM . prompt . Mark
178 -- | Get a view of the current board.
179 getView :: StrategyM View
180 getView = StrategyM (prompt GetView)
182 -- | Get the current board's config.
184 -- Note: the config will never change throughout a game.
185 getConfig :: StrategyM Config
186 getConfig = StrategyM (prompt GetConfig)
188 -- | Provide a debug message.
190 -- These will be displayed in the status line in the GUI or on the
191 -- terminal when running the command line version in verbose mode.
192 traceMine :: String -> StrategyM ()
193 traceMine = StrategyM . prompt . TraceMine
195 -- | A game result.
196 data Result a = Won -- ^ The game was won.
197 | Unfinished a -- ^ The strategy implementation finished
198 -- before the game was over.
199 | Lost -- ^ The game was lost.
200 deriving (Show, Eq)
202 -- | A strategy with some meta-information.
204 -- It's advisable to define your own strategies in terms of 'defaultStrategy'
205 -- so that future additions to that record don't break your code.
206 data Strategy = Strategy {
207 sName :: String, -- ^ The strategy's name. It should be ASCII
208 -- and not contain spaces.
209 sAuthor :: String, -- ^ The strategy's author.
210 sDescription :: String, -- ^ A description of the strategy.
211 sRun :: StdGen -> StrategyM String
212 -- ^ The strategy's implementation.
215 -- | Default values for 'Strategy'.
217 -- > myStrategy :: Strategy
218 -- > myStrategy = defaultStrategy {
219 -- > sName = "Hiho",
220 -- > sRun = \_ -> return "I don't want to play anymore, see you!"
221 -- > }
222 defaultStrategy :: Strategy
223 defaultStrategy = Strategy {
224 sName = "<unknown strategy>",
225 sAuthor = "<unknown author>",
226 sDescription = "This strategy has no description.",
227 sRun = \_ -> return "<unimplemented strategy>"
230 -- | UI interface
232 -- These are actions for the 'MonadPrompt' monad.
234 -- * 'Start' - A new game just started.
236 -- * 'Update' - A move was made, and the indicated cell changed
238 -- * 'Trace' - The strategy provided a trace message.
240 data Play a where
241 Start :: Board -> Play () -- (^ A new game just started.
242 Update :: Pos -> Board -> Play ()
243 -- (^ A move was made, and the indicated cell
244 -- changed
245 Trace :: String -> Board -> Play ()
246 -- (^ The strategy provided a trace message.
248 -- internally, we work in this monad.
249 type PlayM a = StateT Board (Prompt Play) (Result a)
251 -- | Play a game.
253 -- The result is a 'Prompt' action, which is suitable for implementing
254 -- a UI that displays the game's progress.
255 playGameP :: Config -> StdGen -> StrategyM a -> Prompt Play (Result a, Board)
256 playGameP cfg gen strategy = runStateT (game strategy) (mkBoard cfg gen)
257 where
258 game :: StrategyM a -> PlayM a
259 game strategy = do
260 get >>= lift . prompt . Start
261 runPromptC (return . Unfinished) handle (runStrategyM strategy)
263 handle :: Request p -> (p -> PlayM a) -> PlayM a
264 handle GetView cont = gets bView >>= cont
265 handle GetConfig cont = gets bConfig >>= cont
266 handle (Move p) cont = do
267 b@Board { bMines = bm, bView = bv, bTodo = bt } <- get
268 if bm ! p then do put b { bView = bv // [(p, Exploded)] }
269 get >>= lift . prompt . Update p
270 return Lost
271 else case bv ! p of
272 Exposed i -> cont i
273 _ -> do let n = mines b p
274 put b { bView = bv // [(p, Exposed n)],
275 bTodo = bt - 1 }
276 get >>= lift . prompt . Update p
277 if bt == 1 then return Won else cont n
278 handle (Mark p) cont = do
279 b@Board { bMines = bm, bView = bv } <- get
280 when (bv ! p == Hidden) $ do
281 put b { bView = bv // [(p, Marked)] }
282 get >>= lift . prompt . Update p
283 if bm ! p then
284 cont ()
285 else
286 return Lost
287 handle (TraceMine s) cont = get >>= lift . prompt . Trace s >> cont ()
289 -- | A pure version of 'playGameP'.
290 playGame :: Config -> StdGen -> StrategyM a -> (Result a, Board)
291 playGame cfg gen strat = runPrompt handle (playGameP cfg gen strat) where
292 handle :: Play a -> a
293 handle Start {} = ()
294 handle Update {} = ()
295 handle (Trace s b) = ()
298 example won game:
299 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])