src/Mine.hs

   1 {-# LANGUAGE GADTs, FlexibleContexts, Rank2Types, GeneralizedNewtypeDeriving #-}
   2
   3 module Mine (
   4     Config (..),
   5     validConfig,
   6     beginner,
   7     intermediate,
   8     expert,
   9     Pos (..),
  10     Cell (..),
  11     Board (..),
  12     View,
  13     neighbours,
  14     StrategyM,
  15     Strategy (..),
  16     defaultStrategy,
  17     move,
  18     move_,
  19     mark,
  20     getView,
  21     getConfig,
  22     traceMine,
  23     Result (..),
  24     playGame,
  25     Play (..),
  26     playGameP,
  27 ) where
  28
  29 import Control.Monad.Prompt
  30 import Control.Monad.State
  31 import Data.Array
  32 import System.Random
  33
  34 data Pos = Pos { pX :: Int, pY :: Int } deriving (Show, Ord, Eq, Ix)
  35
  36 data Cell = Hidden | Marked | Exploded | Exposed Int deriving Eq
  37
  38 type View = Array Pos Cell
  39
  40 data Board = Board {
  41     bConfig :: Config,
  42     bMines  :: Array Pos Bool,
  43     bView   :: View,
  44     bTodo   :: Int
  45 }
  46
  47 instance Show Board where
  48     show Board { bConfig = Config { cSize = p }, bMines = b, bView = v } =
  49         '\n' : unlines [ "|" ++ concat [cell (Pos x y) | x <- [1..pX p]] ++ " |"
  50                        | y <- [1..pY p]]
  51       where
  52         cell p | b ! p     = case v ! p of
  53                    Hidden    -> " :"
  54                    Marked    -> " X"
  55                    Exploded  -> ">%"
  56                | otherwise = case v ! p of
  57                    Hidden    -> " ."
  58                    Marked    -> " !"
  59                    Exposed 0 -> "  "
  60                    Exposed i -> ' ' : toEnum (48 + i) : ""
  61
  62 data Config = Config {
  63     cSize  :: Pos,
  64     cMines :: Int
  65 } deriving Eq
  66
  67 validConfig :: Config -> Bool
  68 validConfig Config { cSize = sz@(Pos sX sY), cMines = m } =
  69     sX >= 2 && sY >= 2 && m >= 1 && m < sX * sY
  70
  71 beginner, intermediate, expert :: Config
  72 beginner     = Config { cSize = Pos  9  9, cMines = 10 }
  73 intermediate = Config { cSize = Pos 16 16, cMines = 40 }
  74 expert       = Config { cSize = Pos 30 16, cMines = 99 }
  75
  76 mkBoard :: Config -> StdGen -> Board
  77 mkBoard cfg@Config { cSize = sz@(Pos sX sY), cMines = m } gen
  78     | not (validConfig cfg) = error "invalid mine config"
  79     | otherwise = Board {
  80          bConfig = cfg,
  81          bView   = listArray (Pos 1 1, sz) (repeat Hidden),
  82          bMines  = listArray (Pos 1 1, sz) (pick gen (sX * sY) m),
  83          bTodo   = sX * sY - m
  84     }
  85   where
  86     pick gen n m | r <= m    = True  : pick gen' (n-1) (m-1)
  87                  | otherwise = False : pick gen' (n-1) m
  88       where
  89         (r, gen') = randomR (1, n) gen
  90
  91 neighbours :: Config -> Pos -> [Pos]
  92 neighbours Config { cSize = Pos sX sY } (Pos x y) =
  93     [ Pos (x + dx) (y + dy)
  94     | dx <- if x == 1 then [0..1] else if x == sX then [-1..0] else [-1..1],
  95       dy <- if y == 1 then [0..1] else if y == sY then [-1..0] else [-1..1],
  96       dx /= 0 || dy /= 0]
  97
  98 mines :: Board -> Pos -> Int
  99 mines Board { bConfig = cfg, bMines = m } =
 100     length . filter (m !) . neighbours cfg
 101
 102 data Request a where
 103     Move      :: Pos -> Request Int
 104     Mark      :: Pos -> Request ()
 105     GetView   :: Request View
 106     GetConfig :: Request Config
 107     TraceMine :: String -> Request ()
 108
 109 move :: Pos -> StrategyM Int
 110 move = StrategyM . prompt . Move
 111
 112 move_ :: Pos -> StrategyM ()
 113 move_ = (>> return ()) . move
 114
 115 mark :: Pos -> StrategyM ()
 116 mark = StrategyM . prompt . Mark
 117
 118 getView :: StrategyM View
 119 getView = StrategyM (prompt GetView)
 120
 121 getConfig :: StrategyM Config
 122 getConfig = StrategyM (prompt GetConfig)
 123
 124 traceMine :: String -> StrategyM ()
 125 traceMine = StrategyM . prompt . TraceMine
 126
 127 data Result a = Won | Unfinished a | Lost deriving (Show, Eq)
 128
 129 newtype StrategyM a = StrategyM {
 130     runStrategyM :: Prompt Request a
 131 } deriving Monad
 132
 133 data Strategy = Strategy {
 134     sName        :: String,
 135     sAuthor      :: String,
 136     sDescription :: String,
 137     sRun         :: StdGen -> StrategyM String
 138 }
 139
 140 defaultStrategy :: Strategy
 141 defaultStrategy = Strategy {
 142     sName        = "<unknown strategy>",
 143     sAuthor      = "<unknown author>",
 144     sDescription = "This strategy has no description.",
 145     sRun         = \_ -> return "<unimplemented strategy>"
 146 }
 147
 148 data Play a where
 149     Start  :: Board -> Play ()
 150     Update :: Pos -> Board -> Play ()
 151     Trace  :: String -> Board -> Play ()
 152
 153 type PlayM a = StateT Board (Prompt Play) (Result a)
 154
 155 playGameP :: Config -> StdGen -> StrategyM a -> Prompt Play (Result a, Board)
 156 playGameP cfg gen strategy = runStateT (game strategy) (mkBoard cfg gen)
 157   where
 158     game :: StrategyM a -> PlayM a
 159     game strategy = do
 160         get >>= lift . prompt . Start
 161         runPromptC (return . Unfinished) handle (runStrategyM strategy)
 162
 163     handle :: Request p -> (p -> PlayM a) -> PlayM a
 164     handle GetView    cont = gets bView   >>= cont
 165     handle GetConfig  cont = gets bConfig >>= cont
 166     handle (Move p)   cont = do
 167         b@Board { bMines = bm, bView = bv, bTodo = bt } <- get
 168         if bm ! p then do put b { bView = bv // [(p, Exploded)] }
 169                           get >>= lift . prompt . Update p
 170                           return Lost
 171          else case bv ! p of
 172             Exposed i -> cont i
 173             _         -> do let n = mines b p
 174                             put b { bView = bv // [(p, Exposed n)],
 175                                     bTodo = bt - 1 }
 176                             get >>= lift . prompt . Update p
 177                             if bt == 1 then return Won else cont n
 178     handle (Mark p) cont = do
 179         b@Board { bMines = bm, bView = bv } <- get
 180         when (bv ! p == Hidden) $ do
 181             put b { bView = bv // [(p, Marked)] }
 182             get >>= lift . prompt . Update p
 183         if bm ! p then
 184             cont ()
 185          else
 186             return Lost
 187     handle (TraceMine s) cont = get >>= lift . prompt . Trace s >> cont ()
 188
 189 playGame :: Config -> StdGen -> StrategyM a -> (Result a, Board)
 190 playGame cfg gen strat = runPrompt handle (playGameP cfg gen strat) where
 191      handle :: Play a -> a
 192      handle Start {}    = ()
 193      handle Update {}   = ()
 194      handle (Trace s b) = ()
 195
 196 {-
 197 example won game:
 198 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])
 199 -}