Flagging

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
+                refresh 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'
+            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'

src/Minesweeper.hs

@@ -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"
+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 = ""
 
 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/css/minesweeper.css

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

view/custom.js

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