This commit is contained in:
Jack Harley 2021-01-30 13:21:50 +00:00
parent 05eeaae01a
commit 5576cc46e3
4 changed files with 44 additions and 16 deletions

View File

@ -22,7 +22,6 @@ setup w = void $ do
UI.addStyleSheet w "bootstrap.min.css"
UI.addStyleSheet w "minesweeper.css"
rng <- liftIO newStdGen
let b = createBoard 30 0.15 rng :: Board
@ -32,8 +31,10 @@ setup w = void $ do
UI.div #. "container" # set UI.id_ "cont" #+ [
UI.h1 #+ [string "Minesweeper"],
UI.h4 #+ [string "Jack Harley jharley@tcd.ie"],
UI.p #+ [string "Instructions: Click to uncover, right click to flag"],
mkElement "table" # set UI.id_ "table" #+ rows iob b 0
]]
],
mkElement "script" # set (attr "src") "/static/custom.js"]
where
rows iob b r | r < size b = (mkElement "tr" #+ cells iob b r 0) : rows iob b (r+1)
@ -47,16 +48,25 @@ setup w = void $ do
#+ [string $ squareAscii b (r,c)]
on UI.click cell $ \_ -> do
liftIO $ putStrLn "click"
liftIO $ modifyIORef' iob $ \oldB -> uncover oldB (r,c)
b <- liftIO $ readIORef iob
table <- getElementById w "table"
let table' = fromJust table
cont <- getElementById w "cont"
let cont' = return $ fromJust cont
cont' #+ [mkElement "table" # set UI.id_ "table" #+ rows iob b 0]
refresh iob
delete table'
on UI.contextmenu cell $ \_ -> do
liftIO $ putStrLn "rightclick"
liftIO $ modifyIORef' iob $ \oldB -> flag oldB (r,c)
refresh iob
return cell
return cell
refresh iob = do
b <- liftIO $ readIORef iob
table <- getElementById w "table"
let table' = fromJust table
cont <- getElementById w "cont"
let cont' = return $ fromJust cont
cont' #+ [mkElement "table" # set UI.id_ "table" #+ rows iob b 0]
delete table'

View File

@ -52,7 +52,8 @@ isUncovered b (r,c) | validSquare b (r,c) = (uncovered b !! r) !! c
| otherwise = True
isFlagged :: Board -> Square -> Bool
isFlagged b (r,c) = (flagged b !! r) !! c
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
@ -61,17 +62,18 @@ 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) && hasMine b (r,c) = "X"
| isUncovered b (r,c) && adjacentToCovered b (r,c) = show $ adjacentMines b (r,c)
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) | isUncovered b (r,c) && adjacentToCovered b (r,c) =
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"
@ -119,6 +121,17 @@ 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

View File

@ -15,6 +15,10 @@ td {
background-color: red;
}
.flagged {
background-color: yellow;
}
.covered {
background-color: darkgray;
}

1
view/custom.js Normal file
View File

@ -0,0 +1 @@
document.addEventListener('contextmenu', event => event.preventDefault());