src/Mine.hs

   1 {-# LANGUAGE GADTs, FlexibleContexts, Rank2Types, GeneralizedNewtypeDeriving #-}
   2
   3 module Mine (
   4     Pos (..),
   5     Cell (..),
   6     Board (..),
   7     Config (..),
   8     beginner,
   9     intermediate,
  10     expert,
  11     Strategy,
  12     move,
  13     mark,
  14     getView,
  15     getConfig,
  16     Result (..),
  17     playGame,
  18 ) where
  19
  20 import Control.Monad.Prompt
  21 import Control.Monad.State
  22 import Data.Array
  23 import System.Random
  24
  25 data Pos = Pos { pX :: Int, pY :: Int } deriving (Show, Ord, Eq, Ix)
  26
  27 data Cell = Hidden | Marked | Exploded | Exposed Int deriving Eq
  28
  29 type View = Array Pos Cell
  30
  31 data Board = Board {
  32     bConfig :: Config,
  33     bMines  :: Array Pos Bool,
  34     bView   :: View,
  35     bTodo   :: Int
  36 }
  37
  38 instance Show Board where
  39     show Board { bConfig = Config { cSize = p }, bMines = b, bView = v } =
  40         '\n' : unlines [ "|" ++ concat [cell (Pos x y) | x <- [1..pX p]] ++ " |"
  41                        | y <- [1..pY p]]
  42       where
  43         cell p | b ! p = case v ! p of
  44                    Hidden   -> " :"
  45                    Marked   -> " X"
  46                    Exploded -> ">%"
  47                | otherwise = case v ! p of
  48                    Hidden    -> " ."
  49                    Marked    -> " !"
  50                    Exposed 0 -> "  "
  51                    Exposed i -> ' ' : toEnum (48 + i) : ""
  52
  53 data Config = Config {
  54     cSize  :: Pos,
  55     cMines :: Int
  56 }
  57
  58 beginner, intermediate, expert :: Config
  59 beginner     = Config { cSize = Pos  9  9, cMines = 10 }
  60 intermediate = Config { cSize = Pos 16 16, cMines = 40 }
  61 expert       = Config { cSize = Pos 30 16, cMines = 99 }
  62
  63 mkBoard :: Config -> StdGen -> Board
  64 mkBoard cfg@Config { cSize = sz@(Pos sX sY), cMines = m } gen
  65     | sX < 0 || sY < 0 || m < 0 || m > sX * sY = error "invalid mine config"
  66     | otherwise = Board {
  67          bConfig = cfg,
  68          bView   = listArray (Pos 1 1, sz) (repeat Hidden),
  69          bMines  = listArray (Pos 1 1, sz) (pick gen (sX * sY) m),
  70          bTodo   = sX * sY - m
  71     }
  72   where
  73     pick gen n m | r <= m    = True  : pick gen' (n-1) (m-1)
  74                  | otherwise = False : pick gen' (n-1) m
  75       where
  76         (r, gen') = randomR (1, n) gen
  77
  78 neighbours :: Board -> Pos -> Int
  79 neighbours Board { bConfig = Config { cSize = sz }, bMines = m } (Pos x y) =
  80      length [() | dx <- [if x == 1 then 0 else -1..if x==pX sz then 0 else 1],
  81                   dy <- [if y == 1 then 0 else -1..if y==pY sz then 0 else 1],
  82                   dx /= 0 || dy /= 0,
  83                   m ! Pos (x + dx) (y + dy)]
  84 {-
  85      length [() | dx <- [-1..1], dy <- [-1..1], dx /= 0 || dy /= 0,
  86                   x + dx > 0, x + dx <= pX sz, y + dy > 0, y + dy <= pY sz,
  87                   m ! Pos (x + dx) (y + dy)]
  88 -}
  89
  90 {-
  91 revealAll :: Board -> Board
  92 revealAll bd@Board { bMines = m } =
  93     bd { bView = array (bounds m)
  94        [ (p, if o then Marked else Exposed (neighbours bd p))
  95        | (p, o) <- assocs m] }
  96 -}
  97
  98 data Request a where
  99     Move      :: Pos -> Request Int
 100     Toggle    :: Pos -> Request ()
 101     GetView   :: Request View
 102     GetConfig :: Request Config
 103
 104 move :: Pos -> Strategy Int
 105 move = Strategy . prompt . Move
 106
 107 mark :: Pos -> Strategy ()
 108 mark = Strategy . prompt . Toggle
 109
 110 getView :: Strategy View
 111 getView = Strategy (prompt GetView)
 112
 113 getConfig :: Strategy Config
 114 getConfig = Strategy (prompt GetConfig)
 115
 116 data Result a = Won | Unfinished a | Lost deriving (Show, Eq)
 117
 118 newtype Strategy a = Strategy {
 119     runStrategy :: Prompt Request a
 120 } deriving Monad
 121
 122 playGame :: Config -> StdGen -> Strategy a -> (Result a, Board)
 123 playGame cfg gen strategy = runState game (mkBoard cfg gen)
 124   where
 125     game = runPromptC (return . Unfinished) handle (runStrategy strategy)
 126     handle :: Request a -> (a -> State Board (Result b)) -> State Board (Result b)
 127     handle GetView    cnt = gets bView >>= cnt
 128     handle GetConfig  cnt = gets bConfig >>= cnt
 129     handle (Move p)   cnt = do
 130         b@Board { bMines = bm, bView = bv, bTodo = bt } <- get
 131         let n = neighbours b p
 132             b' | bm ! p = b { bView = bv // [(p, Exploded)] }
 133                | otherwise    = case bv ! p of
 134                Exposed i -> b
 135                _         -> b { bView = bv // [(p, Exposed n)], bTodo = bt - 1 }
 136         put b'
 137         if bm ! p then return Lost else
 138             if bTodo b' == 0 then return Won else cnt n
 139     handle (Toggle p) cnt = do
 140         b@Board { bView = bv } <- get
 141         let update Hidden = bv // [(p, Marked)]
 142             update Marked = bv // [(p, Hidden)]
 143             update _      = bv
 144         put b { bView = update (bv ! p) }
 145         if bMines b ! p then
 146             cnt ()
 147          else
 148             return Lost
 149
 150 {-
 151 example won game:
 152 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])
 153 -}