src/Mine.hs

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