HaskellCourse/tp/mine-sweeper/main.hs

-- Mine Sweeper Lab

-- Import section

import Data.Char

import Data.Set ( Set )
import qualified Data.Set as S

import Data.Universe.Helpers ( cartesianProduct ) -- Need to be installed : `cabal install universe`

import Data.List ( foldl1' )

import System.IO

import System.Random

-- Types

data Cell   = Covered Int Bool Bool -- number of bombs around ; has bomb ; has flag
            | Uncovered Int -- number of bombs around
            | Selected

data Grid = Grid [[Cell]]

type Mat = [[Int]]


-- Methods

instance Show Cell where
    show ( Covered _ _ hasFlag ) = if hasFlag then "[F]" else "[ ]"
    show ( Uncovered n ) = ['(', intToDigit n, ')']
    show Selected = ">x<"

instance Show Grid where
    show (Grid a) = unlines $ map (unwords . map show) a

-- Functions

randSet::Int -> StdGen -> StdGen -> Int -> Int -> Set (Int, Int)
randSet n sg1 sg2 h w = 
    let byl = randomRs (0, h - 1) sg1 in
    let bxl = randomRs (0, w - 1) sg2 in
    let bl = zip byl bxl in
    let biggerSets = scanl (flip S.insert) S.empty bl in
    head (dropWhile (\s -> S.size s < n) biggerSets)

grid::Int -> Int -> Set (Int, Int) -> Grid
grid h w s = Grid [ [Covered 0 (S.member (y, x) s) False | x <- [0..w-1] ] | y <- [0..h-1] ]

mineIndic::Cell -> Int
mineIndic c = let Covered _ b _ = c in if b then 1 else 0

mines::Grid -> Mat
mines g = let Grid m = g in map (map mineIndic) m

moveUp::Mat -> Mat
moveUp m = concat [tail m, [[0 | _ <- [1..length (m!!0)]]]]

moveDown::Mat -> Mat
moveDown m = concat [[[0 | _ <- [1..length (m!!0)]]], init m]

moveRight::Mat -> Mat
moveRight m = map (\l -> 0 : init l) m

moveLeft::Mat -> Mat
moveLeft m = map (\l -> concat [tail l, [0]]) m

gridMoves::Mat -> [Mat]
gridMoves m =
    let hMov = [id, moveUp, moveDown] in
    let wMov = [id, moveLeft, moveRight] in
    let allMov = tail $ cartesianProduct (.) hMov wMov in
    map (\f -> f m) allMov

matrixSum::Mat -> Mat -> Mat
matrixSum m1 m2 = zipWith (zipWith (+)) m1 m2

neighbourMap::Grid -> Mat
neighbourMap g =
    let Grid cm = g in
    let m = map (map mineIndic) cm in
    foldl1' matrixSum (gridMoves m)

updateCell::Cell -> Int -> Cell
updateCell c n = case c of
    Covered _ bomb flag -> Covered n bomb flag
    Uncovered _ -> Uncovered n
    Selected -> Selected

updateGrid::Grid -> Mat -> Grid
updateGrid g m =
    let Grid cm = g in
    Grid (zipWith (zipWith updateCell) cm m)

applyi::(a -> a) -> Int -> [a] -> [a]
applyi f i xs =
    let (xs1, xs2) = splitAt i xs in
    concat [xs1, ( (f (head xs2)) : tail xs2 )]

applyij::(a -> a) -> Int -> Int -> [[a]] -> [[a]]
applyij f i j xss = applyi (applyi f j) i xss

uncover::(Int, Int) -> Grid -> Grid
uncover (i, j) g =
    let Grid cm = g in
    let neighbours = tail [(i', j') | i' <- [0, -1, 1], j' <- [0, -1, 1]] in
    let uncoverOneCell = \c -> case c of 
            Covered 0 _ _ -> Uncovered 0 -- TODO : recursion
            Covered n _ _ -> Uncovered n
    in
    Grid (applyij uncoverOneCell i j cm)

-- 5) Main Loop
covIndic::Cell -> Int
covIndic (Covered _ _ _) = 1
covIndic Selected = 1
covIndic _ = 0

won::Grid -> Int -> Bool
won g nbMines =
    let Grid cm = g in
    let nbTotal = (length cm) * (length (cm!!0)) in
    let uncoBinMatrix = map (map covIndic) cm in
    let nbUnco = sum (map sum uncoBinMatrix) in
    nbUnco == nbTotal - nbMines

toggleFlag::Cell -> Cell
toggleFlag (Covered n b flag) = Covered n b (not flag)
toggleFlag c = c

loop::Int -> Int -> Int -> Grid -> IO ()
loop i j n b@(Grid xs)
    | won b n = putStrLn "Victory !"
    | otherwise = do
        putStrLn $ show $ Grid $ applyij ( const Selected ) i j xs
        c <- getChar
        case c of
            'i' -> loop (max (i - 1) 0) j n b -- move caret up
            'k' -> loop (min (i + 1) ((length xs) - 1)) j n b -- move caret down
            'j' -> loop i (max (j - 1) 0) n b -- move caret left
            'l' -> loop i (min (j + 1) ((length (xs!!0)) - 1)) n b -- move caret right
            'f' -> loop i j n (Grid $ applyij toggleFlag i j xs) -- toggle flag
            'u' -> loop i j n (uncover (i, j) b) -- uncover tile
            otherwise -> loop i j n b -- do nothing

main::IO()
main = do
    hSetBuffering stdin NoBuffering -- disable the need to press enter
    hSetEcho stdin False -- dont print input in terminal

    -- random sequences
    sg <- newStdGen
    sg' <- newStdGen

    -- parameters
    let nmines = 5
    let h = 7
    let w = 10

    let bombs = randSet nmines sg sg' h w -- add mines,
    let trappedGrid = grid h w bombs -- create grid
    let scanedGrid = updateGrid trappedGrid (neighbourMap trappedGrid) -- update neighbours

    loop (div h 2) (div w 2) nmines scanedGrid -- start loop