There is an n by m grid that has a random number (between 10% to 20% of the total number of tiles, though older implementations may use 20%..60% instead) of randomly placed mines that need to be found.

Positions in the grid are modified by entering their coordinates where the first coordinate is horizontal in the grid and the second vertical. The top left of the grid is position 1,1; the bottom right is at n,m.

 The total number of mines to be found is shown at the beginning of the game.
 Each mine occupies a single grid point, and its position is initially unknown to the player
 The grid is shown as a rectangle of characters between moves.
 You are initially shown all grids as obscured, by a single dot '.'
 You may mark what you think is the position of a mine which will show as a '?'
 You can mark what you think is free space by entering its coordinates.
 If the point is free space then it is cleared, as are any adjacent points that are also free space- this is repeated recursively for subsequent adjacent free points unless that point is marked as a mine or is a mine.
 Points marked as a mine show as a '?'.
 Other free points show as an integer count of the number of adjacent true mines in its immediate neighborhood, or as a single space ' ' if the free point is not adjacent to any true mines.
 Of course you lose if you try to clear space that has a hidden mine.
 You win when you have correctly identified all mines.
The Task is to create a program that allows you to play minesweeper on a 6 by 4 grid, and that assumes all user input is formatted correctly and so checking inputs for correct form may be omitted.
You may also omit all GUI parts of the task and work using text input and output.

Note: Changes may be made to the method of clearing mines to more closely follow a particular implementation of the game so long as such differences and the implementation that they more accurately follow are described.


C.F: wp:Minesweeper (computer game)

{-# LANGUAGE TemplateHaskell #-}
 
module MineSweeper
  ( Board
  , Cell(..)
  , CellState(..)
  , Pos
    -- lenses / prisms
  , pos
  , coveredLens
  , coveredFlaggedLens
  , coveredMinedLens
  , xCoordLens
  , yCoordLens
    -- Functions
  , emptyBoard
  , groupedByRows
  , displayCell
  , isLoss
  , isWin
  , exposeMines
  , openCell
  , flagCell
  , mineBoard
  , totalRows
  , totalCols )
where
 
import Control.Lens  ((%~), (&), (.~), (^.), (^?), Lens', Traversal', _1, _2,
                      anyOf, filtered, folded, lengthOf, makeLenses, makePrisms,
                      preview, to, view)
import Data.List     (find, groupBy, nub, delete, sortBy)
import Data.Maybe    (isJust)
import System.Random (getStdGen, getStdRandom, randomR, randomRs)
 
type Pos = (Int, Int)
type Board = [Cell]
 
data CellState = Covered   { _mined :: Bool, _flagged :: Bool }
               | UnCovered { _mined :: Bool }
               deriving (Show, Eq)
 
data Cell = Cell
          { _pos :: Pos
          , _state :: CellState
          , _cellId :: Int
          , _adjacentMines :: Int }
          deriving (Show, Eq)
 
makePrisms ''CellState
makeLenses ''CellState
makeLenses ''Cell
 
-- Re-useable lens.
coveredLens :: Traversal' Cell (Bool, Bool) --'
coveredLens = state . _Covered
 
coveredMinedLens, coveredFlaggedLens, unCoveredLens :: Traversal' Cell Bool --'
coveredMinedLens = coveredLens . _1
coveredFlaggedLens = coveredLens . _2
unCoveredLens = state . _UnCovered
 
xCoordLens, yCoordLens :: Lens' Cell Int --'
xCoordLens = pos . _1
yCoordLens = pos . _2
 
-- Adjust row and column size to your preference.
totalRows, totalCols :: Int
totalRows = 4
totalCols = 6
 
emptyBoard :: Board
emptyBoard = (\(n, p) -> Cell { _pos = p
                              , _state = Covered False False
                              , _adjacentMines = 0
                              , _cellId = n }) <$> zip [1..] positions
  where
    positions = (,) <$> [1..totalCols] <*> [1..totalRows]
 
updateCell :: Cell -> Board -> Board
updateCell cell = fmap (\c -> if cell ^. cellId == c ^. cellId then cell else c)
 
updateBoard :: Board -> [Cell] -> Board
updateBoard = foldr updateCell
 
okToOpen :: [Cell] -> [Cell]
okToOpen = filter (\c -> c ^? coveredLens == Just (False, False))
 
openUnMined :: Cell -> Cell
openUnMined = state .~ UnCovered False
 
openCell :: Pos -> Board -> Board
openCell p b = f $ find (\c -> c ^. pos == p) b
 where
  f (Just c)
    | c ^? coveredFlaggedLens == Just True = b
    | c ^? coveredMinedLens == Just True = updateCell
      (c & state .~ UnCovered True)
      b
    | isCovered c = if c ^. adjacentMines == 0 && not (isFirstMove b)
      then updateCell (openUnMined c) $ expandEmptyCells b c
      else updateCell (openUnMined c) b
    | otherwise = b
  f Nothing = b
  isCovered = isJust . preview coveredLens
 
expandEmptyCells :: Board -> Cell -> Board
expandEmptyCells board cell
  | null openedCells = board
  | otherwise = foldr (flip expandEmptyCells) updatedBoard (zeroAdjacent openedCells)
 where
  findMore _ [] = []
  findMore exclude (c : xs)
    | c `elem` exclude        = findMore exclude xs
    | c ^. adjacentMines == 0 = c : adjacent c <>
      findMore (c : exclude <> adjacent c) xs
    | otherwise               = c : findMore (c : exclude) xs
  adjacent     = okToOpen . flip adjacentCells board
  openedCells  = openUnMined <$> nub (findMore [cell] (adjacent cell))
  zeroAdjacent = filter (view (adjacentMines . to (== 0)))
  updatedBoard = updateBoard board openedCells
 
flagCell :: Pos -> Board -> Board
flagCell p board = case find ((== p) . view pos) board of
  Just c  -> updateCell (c & state . flagged %~ not) board
  Nothing -> board
 
adjacentCells :: Cell -> Board -> [Cell]
adjacentCells Cell {_pos = c@(x1, y1)} = filter (\c -> c ^. pos `elem` positions)
  where
    f n = [pred n, n, succ n]
    positions = delete c $ [(x, y) | x <- f x1, x > 0, y <- f y1, y > 0]
 
isLoss, isWin, allUnMinedOpen, allMinesFlagged, isFirstMove :: Board -> Bool
isLoss = anyOf (traverse . unCoveredLens) (== True)
isWin b = allUnMinedOpen b || allMinesFlagged b
 
allUnMinedOpen = (== 0) . lengthOf (traverse . coveredMinedLens . filtered (== False))
allMinesFlagged b = minedCount b == flaggedMineCount b
 where
  minedCount = lengthOf (traverse . coveredMinedLens . filtered (== True))
  flaggedMineCount = lengthOf (traverse . coveredLens . filtered (== (True, True)))
 
isFirstMove = (== totalCols * totalRows) . lengthOf (folded . coveredFlaggedLens . filtered (== False))
 
groupedByRows :: Board -> [Board]
groupedByRows = groupBy (\c1 c2 -> yAxis c1 == yAxis c2)
              . sortBy (\c1 c2 -> yAxis c1 `compare` yAxis c2)
  where
    yAxis = view yCoordLens
 
displayCell :: Cell -> String
displayCell c
  | c ^? unCoveredLens            == Just True = "X"
  | c ^? coveredFlaggedLens       == Just True = "?"
  | c ^? (unCoveredLens . to not) == Just True =
    if c ^. adjacentMines > 0 then show $ c ^. adjacentMines else "▢"
  | otherwise = "."
 
exposeMines :: Board -> Board
exposeMines = fmap (\c -> c & state . filtered (\s -> s ^? _Covered . _1 == Just True) .~ UnCovered True)
 
updateMineCount :: Board -> Board
updateMineCount b = go b
 where
  go []       = []
  go (x : xs) = (x & adjacentMines .~ totalAdjacentMines b) : go xs
   where
    totalAdjacentMines =
      foldr (\c acc -> if c ^. (state . mined) then succ acc else acc) 0 . adjacentCells x
 
-- IO
mineBoard :: Pos -> Board -> IO Board
mineBoard p board = do
  totalMines <- randomMinedCount
  minedBoard totalMines >>= \mb -> pure $ updateMineCount mb
 where
  mines n = take n <$> randomCellIds
  minedBoard n = (\m -> 
    fmap (\c -> if c ^. cellId `elem` m then c & state . mined .~ True else c)
        board) . filter (\c -> openedCell ^. cellId /= c)
      <$> mines n
  openedCell = head $ filter (\c -> c ^. pos == p) board
 
randomCellIds :: IO [Int]
randomCellIds = randomRs (1, totalCols * totalRows) <$> getStdGen
 
randomMinedCount :: IO Int
randomMinedCount = getStdRandom $ randomR (minMinedCells, maxMinedCells)
 where
  maxMinedCells = floor $ realToFrac (totalCols * totalRows) * 0.2
  minMinedCells = floor $ realToFrac (totalCols * totalRows) * 0.1