hs-pgms-0.1.0.1: src/Mine.hs
-- |
-- Module : Mine
-- Copyright : (c) 2008 Bertram Felgenhauer
-- License : BSD3
--
-- Maintainer : Bertram Felgenhauer <int-e@gmx.de>
-- Stability : experimental
-- Portability : portable
--
-- This module is part of Haskell PGMS.
--
-- It provides types and a monad for implementing and running Minesweeper
-- strategies. It's the core of PGMS.
--
module Mine (
-- * Minesweeper configurations
Config (..),
validConfig,
beginner,
intermediate,
expert,
-- * Minesweeper boards
Pos (..),
Cell (..),
Board (..),
View,
neighbours,
-- * Minesweeper strategies
StrategyM,
Strategy (..),
defaultStrategy,
move,
move_,
mark,
getView,
getConfig,
traceMine,
-- * Running Minesweeper games
Result (..),
playGame,
Play (..),
playGameP,
) where
import Control.Monad.Prompt
import Control.Monad.State
import Data.Array.IArray
import Data.Array.Unboxed
import System.Random
-- | A point in 2D space with integer coordinates.
--
-- Used to adress cells on a Minesweeper board, and also to describe board
-- sizes.
data Pos = Pos { pX :: Int, pY :: Int } deriving (Show, Ord, Eq, Ix)
-- | A cell on a Minesweeper board.
data Cell = Hidden -- ^ a hidden cell
| Marked -- ^ a marked cell
| Exploded -- ^ oops, you stepped on a mine here!
| Exposed Int -- ^ an exposed cell with a count of neighbours
deriving (Eq, Show)
-- | A view of the Minesweeper board.
type View = Array Pos Cell
-- | A complete Minesweeper board, including hidden state.
data Board = Board {
bConfig :: Config, -- ^ board size etc.
bMines :: Array Pos Bool, -- ^ array indicating the position of the mines
bView :: View, -- ^ current view
bTodo :: Int -- ^ number of mines left to find
}
instance Show Board where
show Board { bConfig = Config { cSize = p }, bMines = b, bView = v } =
'\n' : unlines [ "|" ++ concat [cell (Pos x y) | x <- [1..pX p]] ++ " |"
| y <- [1..pY p]]
where
cell p | b ! p = case v ! p of
Hidden -> " :"
Marked -> " X"
Exploded -> ">%"
| otherwise = case v ! p of
Hidden -> " ."
Marked -> " !"
Exposed 0 -> " "
Exposed i -> ' ' : toEnum (48 + i) : ""
-- | Description of a mine sweeper configuration (or difficulty).
data Config = Config {
cSize :: Pos, -- ^ the board size
cMines :: Int -- ^ the number of mines placed on the board
} deriving (Eq, Show)
-- | Check validity of a config.
--
-- The width and height must be at least 2, and the number of mines must be
-- between 1 and the number of cells on the board, minus 1.
validConfig :: Config -> Bool
validConfig Config { cSize = sz@(Pos sX sY), cMines = m } =
sX >= 2 && sY >= 2 && m >= 1 && m < sX * sY
-- | Default config: 9x9 with 10 mines
beginner :: Config
beginner = Config { cSize = Pos 9 9, cMines = 10 }
-- | Default config: 16x16 with 40 mines
intermediate :: Config
intermediate = Config { cSize = Pos 16 16, cMines = 40 }
-- | Default config: 30x16 with 99 mines
expert :: Config
expert = Config { cSize = Pos 30 16, cMines = 99 }
-- Create a random board according to the given config.
mkBoard :: Config -> StdGen -> Board
mkBoard cfg@Config { cSize = sz@(Pos sX sY), cMines = m } gen
| not (validConfig cfg) = error "invalid mine config"
| otherwise = Board {
bConfig = cfg,
bView = listArray (Pos 1 1, sz) (repeat Hidden),
bMines = listArray (Pos 1 1, sz) (pick gen (sX * sY) m),
bTodo = sX * sY - m
}
where
pick gen n m | r <= m = True : pick gen' (n-1) (m-1)
| otherwise = False : pick gen' (n-1) m
where
(r, gen') = randomR (1, n) gen
-- | Find the neighbouring cells of a given cell.
--
-- The 'Config' parameter is used to find the boundaries of the board.
neighbours :: Config -> Pos -> [Pos]
neighbours Config { cSize = Pos sX sY } (Pos x y) =
[ Pos (x + dx) (y + dy)
| dx <- if x == 1 then [0..1] else if x == sX then [-1..0] else [-1..1],
dy <- if y == 1 then [0..1] else if y == sY then [-1..0] else [-1..1],
dx /= 0 || dy /= 0]
-- count the mines in the neighbourhood of the given cell
mines :: Board -> Pos -> Int
mines Board { bConfig = cfg, bMines = m } =
length . filter (m !) . neighbours cfg
data Request a where
Move :: Pos -> Request Int
Mark :: Pos -> Request ()
GetView :: Request View
GetConfig :: Request Config
TraceMine :: String -> Request ()
-- | The monad for implementing Minesweeper strategies.
newtype StrategyM a = StrategyM {
runStrategyM :: Prompt Request a
} deriving Monad
-- | Reveal a cell. Returns the number of mines in the neighbourhood.
--
-- Note: Revealing a cell with a mine beneath will lose the game.
move :: Pos -> StrategyM Int
move = StrategyM . prompt . Move
-- | Like 'move', but with no return value.
move_ :: Pos -> StrategyM ()
move_ = (>> return ()) . move
-- | Mark a cell.
--
-- Note: Marking a cell without a mine beneath will lose the game. This is
-- a deviation from standard Minesweeper.
mark :: Pos -> StrategyM ()
mark = StrategyM . prompt . Mark
-- | Get a view of the current board.
getView :: StrategyM View
getView = StrategyM (prompt GetView)
-- | Get the current board's config.
--
-- Note: the config will never change throughout a game.
getConfig :: StrategyM Config
getConfig = StrategyM (prompt GetConfig)
-- | Provide a debug message.
--
-- These will be displayed in the status line in the GUI or on the
-- terminal when running the command line version in verbose mode.
traceMine :: String -> StrategyM ()
traceMine = StrategyM . prompt . TraceMine
-- | A game result.
data Result a = Won -- ^ The game was won.
| Unfinished a -- ^ The strategy implementation finished
-- before the game was over.
| Lost -- ^ The game was lost.
deriving (Show, Eq)
-- | A strategy with some meta-information.
--
-- It's advisable to define your own strategies in terms of 'defaultStrategy'
-- so that future additions to that record don't break your code.
data Strategy = Strategy {
sName :: String, -- ^ The strategy's name. It should be ASCII
-- and not contain spaces.
sAuthor :: String, -- ^ The strategy's author.
sDescription :: String, -- ^ A description of the strategy.
sRun :: StdGen -> StrategyM String
-- ^ The strategy's implementation.
}
-- | Default values for 'Strategy'.
--
-- > myStrategy :: Strategy
-- > myStrategy = defaultStrategy {
-- > sName = "Hiho",
-- > sRun = \_ -> return "I don't want to play anymore, see you!"
-- > }
defaultStrategy :: Strategy
defaultStrategy = Strategy {
sName = "<unknown strategy>",
sAuthor = "<unknown author>",
sDescription = "This strategy has no description.",
sRun = \_ -> return "<unimplemented strategy>"
}
-- | UI interface
--
-- These are actions for the 'MonadPrompt' monad.
--
-- * 'Start' - A new game just started.
--
-- * 'Update' - A move was made, and the indicated cell changed
--
-- * 'Trace' - The strategy provided a trace message.
--
data Play a where
Start :: Board -> Play () -- (^ A new game just started.
Update :: Pos -> Board -> Play ()
-- (^ A move was made, and the indicated cell
-- changed
Trace :: String -> Board -> Play ()
-- (^ The strategy provided a trace message.
-- internally, we work in this monad.
type PlayM a = StateT Board (Prompt Play) (Result a)
-- | Play a game.
--
-- The result is a 'Prompt' action, which is suitable for implementing
-- a UI that displays the game's progress.
playGameP :: Config -> StdGen -> StrategyM a -> Prompt Play (Result a, Board)
playGameP cfg gen strategy = runStateT (game strategy) (mkBoard cfg gen)
where
game :: StrategyM a -> PlayM a
game strategy = do
get >>= lift . prompt . Start
runPromptC (return . Unfinished) handle (runStrategyM strategy)
handle :: Request p -> (p -> PlayM a) -> PlayM a
handle GetView cont = gets bView >>= cont
handle GetConfig cont = gets bConfig >>= cont
handle (Move p) cont = do
b@Board { bMines = bm, bView = bv, bTodo = bt } <- get
if bm ! p then do put b { bView = bv // [(p, Exploded)] }
get >>= lift . prompt . Update p
return Lost
else case bv ! p of
Exposed i -> cont i
_ -> do let n = mines b p
put b { bView = bv // [(p, Exposed n)],
bTodo = bt - 1 }
get >>= lift . prompt . Update p
if bt == 1 then return Won else cont n
handle (Mark p) cont = do
b@Board { bMines = bm, bView = bv } <- get
when (bv ! p == Hidden) $ do
put b { bView = bv // [(p, Marked)] }
get >>= lift . prompt . Update p
if bm ! p then
cont ()
else
return Lost
handle (TraceMine s) cont = get >>= lift . prompt . Trace s >> cont ()
-- | A pure version of 'playGameP'.
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) = ()
{-
example won game:
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])
-}