Minesweeper/src/Minesweeper.hs

module Minesweeper where

import System.Random

type Square = (Int, Int)
type Grid = [[Bool]]

data Board = Board { size :: Int
                   , mines :: Grid
                   , uncovered :: Grid
                   , flagged :: Grid
                   }

-- Creates a board given a size (width/height), mine ratio and random generator
createBoard :: Int -> Float -> StdGen -> Board
createBoard size mineRatio rng = Board size (seedGrid rng mineRatio (createGrid size)) (createGrid size) (createGrid size)

-- Creates a 2D list of booleans of given size, initialised to False
createGrid :: Int -> Grid
createGrid size = replicate size (replicate size False)

-- Functions relating to seeding a grid with mines

seedGrid :: StdGen -> Float -> Grid -> Grid
seedGrid _ _ [] = []
seedGrid rng p (l:ls) = newL : seedGrid rng2 p ls
                        where (rng1, rng2) = split rng
                              (newL, _) = seedList rng1 p l

seedList :: StdGen -> Float -> [Bool] -> ([Bool], StdGen)
seedList rng p (l:ls) = (newBool : seedList' newRng p ls, newRng)
                        where (newBool, newRng) = weightedRandomBool rng p
seedList' :: StdGen -> Float -> [Bool] -> [Bool]
seedList' _ _ [] = []
seedList' rng p (l:ls) = newBool : seedList' newRng p ls
                         where (newBool, newRng) = weightedRandomBool rng p

-- Returns true with probability p, otherwise false
weightedRandomBool :: StdGen -> Float -> (Bool, StdGen)
weightedRandomBool rng p = (generatedFloat <= p, newRng)
                     where (generatedFloat, newRng) = randomR (0.0, 1.0) rng

-- Functions for determing statuses and info on square(s)
-- N.B. (r,c) = (row, column)

hasMine :: Board -> Square -> Bool
hasMine b (r,c) | validSquare b (r,c) = (mines b !! r) !! c
                | otherwise = False

isUncovered :: Board -> Square -> Bool
isUncovered b (r,c) | validSquare b (r,c) = (uncovered b !! r) !! c
                    | otherwise = True

isFlagged :: Board -> Square -> Bool
isFlagged b (r,c) | validSquare b (r,c) = (flagged b !! r) !! c
                  | otherwise = False

validSquare :: Board -> Square -> Bool
validSquare b (r,c) = r >= 0 && c >= 0 && r < size b && c < size b

onEdge :: Board -> Square -> Bool
onEdge b (r,c) = r == 0 || c == 0 || r+1 == size b || c+1 == size b

squareAscii :: Board -> Square -> String
squareAscii b (r,c) | isUncovered b (r,c) && adjacentToCovered b (r,c) = show $ adjacentMines b (r,c)
                    | otherwise = ""

squareBgColour :: Board -> Square -> String
squareBgColour b (r,c) | isUncovered b (r,c) && hasMine b (r,c) = "bomb"
                       | isUncovered b (r,c) = "uncovered"
                       | isFlagged b (r,c) = "flagged"
                       | otherwise = "covered"

squareTextColour :: Board -> Square -> String
squareTextColour b (r,c) | hasMine b (r,c) || isFlagged b (r,c) = ""
                         | isUncovered b (r,c) && adjacentToCovered b (r,c) = 
                           case adjacentMines b (r,c) of
                              1 -> "text-blue"
                              2 -> "text-green"
                              3 -> "text-red"
                              4 -> "text-purple"
                              5 -> "text-maroon"
                              6 -> "text-turquoise"
                              7 -> "text-black"
                              8 -> "text-gray"
                         | otherwise = ""

adjacentMines :: Board -> Square -> Int
adjacentMines b (r,c) = sum $ map (boolToInt . hasMine b) $ adjacentSquares (r,c)

adjacentToCovered :: Board -> Square -> Bool
adjacentToCovered b (r,c) = not $ all (isUncovered b) $ adjacentSquares (r,c)

adjacentSquares :: Square -> [Square]
adjacentSquares (r,c) = [(r-1,c-1), (r-1,c), (r-1,c+1), (r,c-1), (r,c+1), (r+1,c-1), (r+1,c), (r+1,c+1)]

boolToInt :: Bool -> Int
boolToInt x | x = 1
            | otherwise = 0

-- Functions for changing the status of square(s)

-- uncovers a square and recursively uncovers adjacent squares iff the square has zero adjacent mines
-- N.B. not very efficient due to lots of splitting and remerging
uncover :: Board -> Square -> Board
uncover b (r,c) | not $ validSquare b (r,c) = b
                | isUncovered b (r,c) = b
                | otherwise = let Board s m u f = b
                                  (rowsA, row : rowsB) = splitAt r u
                                  (cellsA, _ : cellsB) = splitAt c row
                                  newRow = cellsA ++ True : cellsB
                                  newRows = rowsA ++ newRow : rowsB
                              in uncoverAdjacentsIfSafe (Board s m newRows f) (r,c)

uncoverAdjacentsIfSafe :: Board -> Square -> Board
uncoverAdjacentsIfSafe b (r,c) | adjacentMines b (r,c) == 0 = uncoverAll b $ adjacentSquares (r,c)
                               | otherwise = b

-- uncovers all squares given in a list
uncoverAll :: Board -> [Square] -> Board
uncoverAll b [] = b
uncoverAll b ((r,c):xs) = uncoverAll newB xs where newB = uncover b (r,c)

flag :: Board -> Square -> Board
flag b (r,c) | not $ validSquare b (r,c) = b
             | isUncovered b (r,c) = b
             | isFlagged b (r,c) = b
             | otherwise = let Board s m u f = b
                               (rowsA, row : rowsB) = splitAt r f
                               (cellsA, _ : cellsB) = splitAt c row
                               newRow = cellsA ++ True : cellsB
                               newRows = rowsA ++ newRow : rowsB
                           in Board s m u newRows

-- Functions for turning a board into a string for debug purposes

printBoard :: Board -> String
printBoard b = printBoardGrid (mines b)

printBoardGrid :: Grid -> String
printBoardGrid [] = ""
printBoardGrid (l:ls) = printBoardLine l ++ "\n" ++ printBoardGrid ls

printBoardLine :: [Bool] -> String 
printBoardLine [] = ""
printBoardLine (x:xs) = (if x then " x" else " .") ++ printBoardLine xs