Flagging
This commit is contained in:
parent
05eeaae01a
commit
5576cc46e3
18
src/Main.hs
18
src/Main.hs
|
@ -22,7 +22,6 @@ setup w = void $ do
|
||||||
|
|
||||||
UI.addStyleSheet w "bootstrap.min.css"
|
UI.addStyleSheet w "bootstrap.min.css"
|
||||||
UI.addStyleSheet w "minesweeper.css"
|
UI.addStyleSheet w "minesweeper.css"
|
||||||
|
|
||||||
rng <- liftIO newStdGen
|
rng <- liftIO newStdGen
|
||||||
|
|
||||||
let b = createBoard 30 0.15 rng :: Board
|
let b = createBoard 30 0.15 rng :: Board
|
||||||
|
@ -32,8 +31,10 @@ setup w = void $ do
|
||||||
UI.div #. "container" # set UI.id_ "cont" #+ [
|
UI.div #. "container" # set UI.id_ "cont" #+ [
|
||||||
UI.h1 #+ [string "Minesweeper"],
|
UI.h1 #+ [string "Minesweeper"],
|
||||||
UI.h4 #+ [string "Jack Harley jharley@tcd.ie"],
|
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 "table" # set UI.id_ "table" #+ rows iob b 0
|
||||||
]]
|
],
|
||||||
|
mkElement "script" # set (attr "src") "/static/custom.js"]
|
||||||
|
|
||||||
where
|
where
|
||||||
rows iob b r | r < size b = (mkElement "tr" #+ cells iob b r 0) : rows iob b (r+1)
|
rows iob b r | r < size b = (mkElement "tr" #+ cells iob b r 0) : rows iob b (r+1)
|
||||||
|
@ -47,7 +48,18 @@ setup w = void $ do
|
||||||
#+ [string $ squareAscii b (r,c)]
|
#+ [string $ squareAscii b (r,c)]
|
||||||
|
|
||||||
on UI.click cell $ \_ -> do
|
on UI.click cell $ \_ -> do
|
||||||
|
liftIO $ putStrLn "click"
|
||||||
liftIO $ modifyIORef' iob $ \oldB -> uncover oldB (r,c)
|
liftIO $ modifyIORef' iob $ \oldB -> uncover oldB (r,c)
|
||||||
|
refresh iob
|
||||||
|
|
||||||
|
on UI.contextmenu cell $ \_ -> do
|
||||||
|
liftIO $ putStrLn "rightclick"
|
||||||
|
liftIO $ modifyIORef' iob $ \oldB -> flag oldB (r,c)
|
||||||
|
refresh iob
|
||||||
|
|
||||||
|
return cell
|
||||||
|
|
||||||
|
refresh iob = do
|
||||||
b <- liftIO $ readIORef iob
|
b <- liftIO $ readIORef iob
|
||||||
|
|
||||||
table <- getElementById w "table"
|
table <- getElementById w "table"
|
||||||
|
@ -58,5 +70,3 @@ setup w = void $ do
|
||||||
cont' #+ [mkElement "table" # set UI.id_ "table" #+ rows iob b 0]
|
cont' #+ [mkElement "table" # set UI.id_ "table" #+ rows iob b 0]
|
||||||
|
|
||||||
delete table'
|
delete table'
|
||||||
|
|
||||||
return cell
|
|
|
@ -52,7 +52,8 @@ isUncovered b (r,c) | validSquare b (r,c) = (uncovered b !! r) !! c
|
||||||
| otherwise = True
|
| otherwise = True
|
||||||
|
|
||||||
isFlagged :: Board -> Square -> Bool
|
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 :: Board -> Square -> Bool
|
||||||
validSquare b (r,c) = r >= 0 && c >= 0 && r < size b && c < size b
|
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
|
onEdge b (r,c) = r == 0 || c == 0 || r+1 == size b || c+1 == size b
|
||||||
|
|
||||||
squareAscii :: Board -> Square -> String
|
squareAscii :: Board -> Square -> String
|
||||||
squareAscii b (r,c) | isUncovered b (r,c) && hasMine b (r,c) = "X"
|
squareAscii b (r,c) | isUncovered b (r,c) && adjacentToCovered b (r,c) = show $ adjacentMines b (r,c)
|
||||||
| isUncovered b (r,c) && adjacentToCovered b (r,c) = show $ adjacentMines b (r,c)
|
|
||||||
| otherwise = ""
|
| otherwise = ""
|
||||||
|
|
||||||
squareBgColour :: Board -> Square -> String
|
squareBgColour :: Board -> Square -> String
|
||||||
squareBgColour b (r,c) | isUncovered b (r,c) && hasMine b (r,c) = "bomb"
|
squareBgColour b (r,c) | isUncovered b (r,c) && hasMine b (r,c) = "bomb"
|
||||||
| isUncovered b (r,c) = "uncovered"
|
| isUncovered b (r,c) = "uncovered"
|
||||||
|
| isFlagged b (r,c) = "flagged"
|
||||||
| otherwise = "covered"
|
| otherwise = "covered"
|
||||||
|
|
||||||
squareTextColour :: Board -> Square -> String
|
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
|
case adjacentMines b (r,c) of
|
||||||
1 -> "text-blue"
|
1 -> "text-blue"
|
||||||
2 -> "text-green"
|
2 -> "text-green"
|
||||||
|
@ -119,6 +121,17 @@ uncoverAll :: Board -> [Square] -> Board
|
||||||
uncoverAll b [] = b
|
uncoverAll b [] = b
|
||||||
uncoverAll b ((r,c):xs) = uncoverAll newB xs where newB = uncover b (r,c)
|
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
|
-- Functions for turning a board into a string for debug purposes
|
||||||
|
|
||||||
printBoard :: Board -> String
|
printBoard :: Board -> String
|
||||||
|
|
|
@ -15,6 +15,10 @@ td {
|
||||||
background-color: red;
|
background-color: red;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
.flagged {
|
||||||
|
background-color: yellow;
|
||||||
|
}
|
||||||
|
|
||||||
.covered {
|
.covered {
|
||||||
background-color: darkgray;
|
background-color: darkgray;
|
||||||
}
|
}
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
document.addEventListener('contextmenu', event => event.preventDefault());
|
Loading…
Reference in New Issue