Flagging
This commit is contained in:
parent
05eeaae01a
commit
5576cc46e3
34
src/Main.hs
34
src/Main.hs
|
@ -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'
|
|
@ -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
|
||||
|
|
|
@ -15,6 +15,10 @@ td {
|
|||
background-color: red;
|
||||
}
|
||||
|
||||
.flagged {
|
||||
background-color: yellow;
|
||||
}
|
||||
|
||||
.covered {
|
||||
background-color: darkgray;
|
||||
}
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
document.addEventListener('contextmenu', event => event.preventDefault());
|
Loading…
Reference in New Issue