Minesweeper in haskell

Question

I have recently been learning Haskell, and wrote a minesweeper project as an exercise. Here is link to the project.

Basically the code is separated into two parts, the pure part (no monads) and impure part (deals with random and IO). Since I'm pretty new, I'm a little iffy about the whole setup. Any advice would be appreciated.

{-# LANGUAGE LambdaCase #-}
module Game where

import Data.List
import Data.Maybe
import Data.List.Split
import Control.Monad.Random
import Control.Monad.IO.Class
import Control.Monad.Reader

data Square = Square Bool SquareStatus | NumberedSquare Int
data SquareStatus = Untouched | LostMine | Flagged
data Pos = Pos Int Int deriving (Eq)
data Env = Env {
  getInitPos :: Pos,
  getWidth :: Int,
  getHeight :: Int,
  getNumMines :: Int
}

type Board = [[Square]]
type Game a = ReaderT Env IO a

instance Show Square where
  show (Square _ Untouched) = "."
  show (Square _ LostMine) = "x"
  show (Square _ Flagged) = "f"
  show (NumberedSquare num) = if num > 0 then show num else " "

infixl 6 |+|
Pos a b |+| Pos c d = Pos (a+c) (b+d)

---------------
-- Game Control
---------------
play :: Int -> Int -> Int -> IO ()
play w h numMines = do
  initPos <- readInput
  board <- runReaderT createRandomBoard $ Env initPos w h numMines
  play' board initPos

play' :: Board -> Pos -> IO ()
play' board initPos = case expand board [initPos] of
    Just nextBoard -> do 
      printBoard nextBoard
      if checkWin nextBoard then 
        print "You won!"
      else do
        nextPos <- readInput
        play' nextBoard nextPos
    Nothing -> do
      print "You Lost :("
      printBoard $ markBoard board

readInput :: IO Pos
readInput = do
  pos <- do
    putStrLn "Make a move: (Format Int Int)"
    getLine
  let [initX, initY] = splitOn " " pos
  return $ Pos (read initX - 1) (read initY - 1)

--------------
--Impure Stuff
--------------
createRandomBoard :: Game Board
createRandomBoard = do
  width <- asks getWidth
  height <- asks getHeight
  randomLayout <- randMines
  let field = take height $ chunksOf width $ genField randomLayout $ width * height
  lift $ return field

randMines :: Game [Int]
randMines = do
  width <- asks getWidth
  height <- asks getHeight
  pos <- asks getInitPos
  n <- asks getNumMines
  randomSample n $ delete (posToIndex pos width height) [0..width*height-1]

randomSample :: Int -> [a] -> Game [a]
randomSample 0 list = pure []
randomSample k list = do
  i <- getRandomR (0, length list - 1)
  let (a, xs) = splitAt i list
  l <- if not (null xs) then randomSample (k-1) (a ++ tail xs) else lift $ return []
  pure $ if not (null xs) then head xs : l else l

----------------
--Pure Functions
----------------
genField :: [Int] -> Int -> [Square]
genField mines = genField' (sort mines) 0
  where
  genField' [] index size = replicate (size - index) (Square False Untouched)
  genField' mines@(x:xs) index size
    | x == index = Square True Untouched : genField' xs (index+1) size
    | otherwise = Square False Untouched : genField' mines (index+1) size

getSquare :: Board -> Pos -> Maybe Square
getSquare b (Pos x y)
  | x >= length b || x < 0 = Nothing
  | y >= length (head b) || y < 0 = Nothing
  | otherwise = Just (b !! x !! y)

getNearMines :: Board -> Pos -> Int
getNearMines b pos =
  let 
    d = [-1, 0, 1]
    dirs = (|+|) <$> [Pos a b| a <- d, b <- d] <*> [pos]
  in
    foldl (\acc p -> case getSquare b p of
                       Just (Square True _) -> acc + 1
                       _ -> acc) 0 dirs
  
getExpansions :: Board -> Pos -> [Pos]
getExpansions b pos =
  case getSquare b pos of
    Nothing -> []
    Just (Square True _) -> []
    Just _ -> expansions
  where
    isZero = getNearMines b pos == 0
    ds = if isZero then
            [Pos a b | a <- [-1, 0, 1], b <- [-1, 0, 1]]
          else
            [Pos a b | (a,b) <- [(-1, 0), (0, -1), (1, 0), (0, 1), (0, 0)]]
    dirs = (|+|) <$> ds <*> [pos]
    bounded_dirs = filter (\(Pos x y) -> x >= 0 && y >= 0) dirs
    filtered_dirs = if isZero then 
                      bounded_dirs
                    else
                      filter (\n -> n == pos || getNearMines b n == 0) bounded_dirs
    expansions = foldl (\acc p -> case getSquare b p of
                        Just s@(Square False Untouched) -> p : acc
                        _ -> acc) [] filtered_dirs

expand :: Board -> [Pos] -> Maybe Board
expand b p = do
  let expansions = concat $ mapMaybe (expand' b) p
  let newboard = foldr (\(ri, row) r ->
                  foldr (\(ci, s) c ->
                    if Pos ri ci `elem` expansions then
                      NumberedSquare (getNearMines b $ Pos ri ci) : c
                    else 
                      s : c
                  ) [] (zip [0..] row) : r
                ) [] (zip [0..] b)
  let removeCur = filter (`notElem` p) expansions
  if not $ lost b p then
    if null removeCur then 
      return newboard 
    else 
      expand newboard removeCur
  else
    Nothing
  where
    expand' :: Board -> Pos -> Maybe [Pos]
    expand' b' p' =
      case getSquare b' p' of
        Nothing -> Nothing
        Just (Square True _ ) -> Nothing
        _ -> Just (getExpansions b' p')

    lost :: Board -> [Pos] -> Bool
    lost _ [] = False
    lost b' (x:xs) =
      case getSquare b' x of
        Just (Square True _) -> True
        _ -> lost b' xs

checkWin :: Board -> Bool
checkWin b = 
  all (==True) $ 
  fmap (all (==True) . 
    fmap (\case
            Square False Untouched -> False
            _ -> True)) b

-----------
--Utilities
-----------
indexToPos :: Int -> Int -> Int -> Pos
indexToPos index w h = Pos (mod index w) (index `div` w)

posToIndex :: Pos -> Int -> Int -> Int
posToIndex (Pos x y) w h = y * w + x

printBoard :: Board -> IO ()
printBoard b = do
  let width = length $ head b
  putStrLn $ replicate (width * 2) '-'
  mapM_ (putStrLn . unwords . fmap show) b
  putStrLn $ replicate (length b * 2) '-'

markBoard :: Board -> Board
markBoard b =
  foldr (\(ri, row) r ->
    foldr (\(ci, s) c ->
      case s of
        Square False _ -> NumberedSquare (getNearMines b $ Pos ri ci) : c
        Square True _ -> Square True LostMine : c
        _ -> s : c
    ) [] (zip [0..] row) : r
  ) [] (zip [0..] b)

Answer 1

Incomplete player interface

There is no way for a player to mark a square as mined. Technically, you can beat the game without, but that is not the point here?

Missing entry point

You did not state an entry point, from the linked project:

main :: IO ()
main = do
  args <- getArgs
  let [w, h, numMines] = args
  play (read w) (read h) (read numMines)

Can be done as

  [w, h, mineCount] <- map read <$> getArgs
  play w h mineCount

Data structures

I do not need many comments, but your data definition would certainly benefit:

data Square = Square Bool SquareStatus | NumberedSquare Int

So what does the Bool stand for? How is a mine represented? Took me a while to figure it out.

The name NumberedSquare is about the view, not the model/business logic. My taste here is different than yours.

Generally in haskell it is recommended to either have only one data constructor with the same name as the type or different constructor names, e.g.

data Tile = Closed Bool PlayerMarking | Opened Int

In my professional experience, the term status is overused and lost meaning. I'd rename SquareStatus to PlayerMarking.

From the later code I see that you calculate the neighboring mines once a square is opened. I think your code can be made easier if you calculate it in advance and have:

data Square = Square { isMined :: Bool
                     , neighboringMines :: Int
                     , playerMarking :: PlayerMarking
                     , opened :: Bool
                     } deriving ...

You might want to split the mutable state openend and playerMarking from the pre-computed isMined and opened, but I have no idea at this time.

So now you have a function isMined :: Square -> Bool. Even if you refactor the data structure (e.g. the just mentioned split), you might be able the write your own isMined.

You use the environment data Env = Env only in the generation of the Board. Environment is another word that does not carry much meaning. How about BoardGenerationParameters or simply Difficulty?

Show instance

The Show typeclass instance Show Square where should not be used for pretty-printing, as documented in the Prelude. Just have a function prettyPrint, no need for a typeclass or instance.

And do you want to let your player count rows and columns? Coordinates are needed for input. Include those in pretty-printing.

Type declaration for operators

infixl 6 |+|
Pos a b |+| Pos c d = Pos (a+c) (b+d)

Where is (|+|) :: Pos -> Pos -> Pos? I presume you once made Pos an instance of Num and then took it back (good)?!

Anyway, Pos and indices can be mostly avoided.

Did you step on a mine?

It becomes hard to follow the logic in play. Why do you expand the Board into Nothing if you open a mine field? Just check right after getLine if it is a mine, boom!

Board generation

You take all board indices, take out the initial click, the take a random sample of NumMines and then iterate over all board indices again to generate [Square], which is then handed over to chunksOf. Took me a while to figure that out. I expect a rather easy chain with function composition. Where is it? Ah:

let field = take height $ chunksOf width $ genField randomLayout $ width * height
lift $ return field

More idiomatic as

lift . return . take height . chunksOf width $ genField randomLayout

But the logic of genField and the index can be made simpler (Arguably). Instead of a random sample, I'd start with a list of Bools

replicate numMines True ++ replicate (w*h - numMines) False

and treat this as a deck of cards. Now you can just shuffle it with Fisher-Yates. Unfortunately, hoogle did not give me a simple result, i.e. one that works in IO or with RandomGen After the shuffle of [Bool], just do the chunksOf. This way you can avoid the indices. You lose the logic of "first opened square is never is mine", but you can start with w*h - 1 cards and insert a false after shuffling.

Foldl and simpler functions

I try to avoid folds, simply because I cannot remember their signature. Instead of

getNearMines b pos = -- ...
    foldl (\acc p -> case getSquare b p of
                       Just (Square True _) -> acc + 1
                       _ -> acc) 0 dirs

you can use filter and length:

    length . filter isMined $ dirs

Even without the recommended isMined predicate, here is a trick I learned in golfing. (Food for thought, not a real improvement, but closer to your fold)

    sum [ 1 | (Just (Square True _)) <- dirs ]

in a list comprehension, you can pattern match, so all neighbors from dirs that don't match are discarded.

Binary operators in Applicatives

For an operator #, a common way of writing (#) <$> a <*> b is a <#> b where (<#>) = liftA2 (#), so

dirs = (|+|) <$> [Pos a b| a <- d, b <- d] <*> [pos]

could be

dirs = [Pos a b| a <- d, b <- d] <+> [pos]
        where (<+>) = liftA2 (|+|)

but here, that does not look better. In both instances where you use |+| you could use it as simple functor (actually just map) with operator section

dirs = map (|+| pos) [Pos a b| a <- d, b <- d]

checkWin

all (==True) is simply and :: [Bool] -> Bool (ignoring Foldable for now) and all (==True) . fmap p is just all p Edit: the latter can be done twice. Add an eta reduction and it becomes

checkWin = all (all (\case
                      Square False Untouched -> False
                      _ -> True))

But it is more readable as

checkWin = all minelessSquareOpened . concat where
               minelessSquareOpened (Square False Untouched) = False
               minelessSquareOpened _ = True

minelessSquareOpened can be called better, I just considered unminedImpliesOpen to be worse.

foldr vs map

those foldrs in markBoard and expand can be written as simple maps.

indices and !!

The use of list indices and !! is not regarded as idiomatic haskell, and here, you can do mostly without. (Mostly? It is inevitable for the player input.)

To count the neighbors without using indices, you can use something like

\board -> zip3 
               (emptyLine ++ init board)
               board
               (tail board ++ emptyLine)

to group one row with the preceeding and following row and do the same for columns.