src/Mine.hs

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