Add Day 4, Puzzle 2 solution

src/Day04.hs

@@ -2,6 +2,7 @@
 
 module Day04
   ( day04_1,
+    day04_2,
   )
 where
 
@@ -20,28 +21,49 @@ move position U = (fst position, snd position - 1)
 move position RU = (fst position + 1, snd position - 1)
 move position L = (fst position - 1, snd position)
 move position R = (fst position + 1, snd position)
-move position LD = (fst position -1, snd position + 1)
+move position LD = (fst position - 1, snd position + 1)
 move position D = (fst position, snd position + 1)
 move position RD = (fst position + 1, snd position + 1)
 
 getValue :: Grid -> Position -> Char
-getValue grid position 
-    | not $ isInside position (length (head grid)) (length grid) = '.'
-    | otherwise = (grid !! snd position) !! fst position
+getValue grid position
+  | not $ isInside position (length (head grid)) (length grid) = '.'
+  | otherwise = (grid !! snd position) !! fst position
 
 getAdjacent :: Grid -> Position -> Int
 getAdjacent grid position = length . filter (== '@') $ map (getValue grid . move position) [LU .. RD]
 
 isAccessible :: Grid -> Position -> Bool
 isAccessible grid position
-    | getValue grid position == '.' = False
-    | otherwise = getAdjacent grid position < 4
+  | getValue grid position == '.' = False
+  | otherwise = getAdjacent grid position < 4
 
 countAccessible :: Grid -> Int
-countAccessible grid =  let w = length $ head grid
-                            h = length grid
-                            positions = [ (x, y) | x <- [0..w - 1], y <- [0..h - 1]]
-                         in length . filter id $ map (isAccessible grid) positions
+countAccessible grid =
+  let w = length $ head grid
+      h = length grid
+      positions = [(x, y) | x <- [0 .. w - 1], y <- [0 .. h - 1]]
+   in length . filter id $ map (isAccessible grid) positions
+
+removePaper :: Grid -> Position -> Grid
+removePaper grid position = take (snd position) grid ++ newRow ++ drop (snd position + 1) grid
+  where
+    newRow = [take (fst position) (grid !! snd position) ++ ['.'] ++ drop (fst position + 1) (grid !! snd position)]
+
+removeAccessible :: Grid -> Grid
+removeAccessible grid =
+  let w = length $ head grid
+      h = length grid
+      positions = filter (isAccessible grid) [(x, y) | x <- [0 .. w - 1], y <- [0 .. h - 1]]
+   in removeRecursive grid positions
+  where
+    removeRecursive grid' [] = grid'
+    removeRecursive grid' (p : ps) = removeRecursive (removePaper grid' p) ps
+
+countAccessibleRecursive :: Grid -> Int -> Int
+countAccessibleRecursive grid tot
+  | countAccessible grid == 0 = tot
+  | otherwise = countAccessibleRecursive (removeAccessible grid) (tot + countAccessible grid)
 
 parseInput :: IO [String]
 parseInput = lines <$> readFile "input/day4.txt"
@@ -53,3 +75,11 @@ day04_1 = do
   putStrLn $
     "Day 4, Puzzle 1 solution: "
       ++ show result
+
+day04_2 :: IO ()
+day04_2 = do
+  grid <- parseInput
+  let result = countAccessibleRecursive grid 0
+  putStrLn $
+    "Day 4, Puzzle 2 solution: "
+      ++ show result

src/Main.hs

@@ -3,7 +3,7 @@ module Main (main) where
 import Day01 (day01_1, day01_2)
 import Day02 (day02_1, day02_2)
 import Day03 (day03_1, day03_2)
-import Day04 (day04_1)
+import Day04 (day04_1, day04_2)
 import System.Environment (getArgs)
 
 main :: IO ()
@@ -26,8 +26,10 @@ main = do
       day03_1
       day03_2
     "4" : "1" : _ -> day04_1
+    "4" : "2" : _ -> day04_2
     "4" : _ -> do
       day04_1
+      day04_2
     "all" : _ -> do
       day01_1
       day01_2
@@ -36,4 +38,5 @@ main = do
       day03_1
       day03_2
       day04_1
+      day04_2
     _ -> error "Not implemented"