src/Mine.hs

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