module Mine (
Config (..),
validConfig,
beginner,
intermediate,
expert,
Pos (..),
Cell (..),
Board (..),
View,
neighbours,
StrategyM,
Strategy (..),
defaultStrategy,
move,
move_,
mark,
getView,
getConfig,
traceMine,
Result (..),
playGame,
Play (..),
playGameP,
) where
import Control.Monad.Prompt
import Control.Monad.State
import Data.Array.IArray
import Data.Array.Unboxed
import System.Random
data Pos = Pos { pX :: Int, pY :: Int } deriving (Show, Ord, Eq, Ix)
data Cell = Hidden
| Marked
| Exploded
| Exposed Int
deriving (Eq, Show)
type View = Array Pos Cell
data Board = Board {
bConfig :: Config,
bMines :: Array Pos Bool,
bView :: View,
bTodo :: Int
}
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) : ""
data Config = Config {
cSize :: Pos,
cMines :: Int
} deriving (Eq, Show)
validConfig :: Config -> Bool
validConfig Config { cSize = sz@(Pos sX sY), cMines = m } =
sX >= 2 && sY >= 2 && m >= 1 && m < sX * sY
beginner :: Config
beginner = Config { cSize = Pos 9 9, cMines = 10 }
intermediate :: Config
intermediate = Config { cSize = Pos 16 16, cMines = 40 }
expert :: Config
expert = Config { cSize = Pos 30 16, cMines = 99 }
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' (n1) (m1)
| otherwise = False : pick gen' (n1) m
where
(r, gen') = randomR (1, n) gen
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]
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 ()
newtype StrategyM a = StrategyM {
runStrategyM :: Prompt Request a
} deriving Monad
move :: Pos -> StrategyM Int
move = StrategyM . prompt . Move
move_ :: Pos -> StrategyM ()
move_ = (>> return ()) . move
mark :: Pos -> StrategyM ()
mark = StrategyM . prompt . Mark
getView :: StrategyM View
getView = StrategyM (prompt GetView)
getConfig :: StrategyM Config
getConfig = StrategyM (prompt GetConfig)
traceMine :: String -> StrategyM ()
traceMine = StrategyM . prompt . TraceMine
data Result a = Won
| Unfinished a
| Lost
deriving (Show, Eq)
data Strategy = Strategy {
sName :: String,
sAuthor :: String,
sDescription :: String,
sRun :: StdGen -> StrategyM String
}
defaultStrategy :: Strategy
defaultStrategy = Strategy {
sName = "<unknown strategy>",
sAuthor = "<unknown author>",
sDescription = "This strategy has no description.",
sRun = \_ -> return "<unimplemented strategy>"
}
data Play a where
Start :: Board -> Play ()
Update :: Pos -> Board -> Play ()
Trace :: String -> Board -> Play ()
type PlayM a = StateT Board (Prompt Play) (Result a)
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 ()
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) = ()