6

Part 2 is very slow, but meh?

1 files changed, 41 insertions, 0 deletions

diff --git a/2024/6.hs b/2024/6.hs
new file mode 100644
index 0000000..6fe65bf
--- /dev/null
+++ b/2024/6.hs
@@ -0,0 +1,41 @@
+import Data.List (findIndex, find)
+import Data.Maybe (isJust, fromJust, isNothing)
+import qualified Data.Set as Set
+import qualified Data.Array as A
+
+main :: IO ()
+main = do
+  let bd `at` (x, y) = bd A.! (y, x)
+  let inBounds bd (x, y) =
+        let (_, (h, w)) = A.bounds bd
+        in x >= 0 && y >= 0 && x <= w && y <= h
+  let (x, y) +. (dx, dy) = (x + dx, y + dy)
+  let rot (dx, dy) = (-dy, dx)
+  let walk :: A.Array (Int, Int) Char
+           -> (Int, Int) -> (Int, Int)
+           -> Set.Set ((Int, Int), (Int, Int))
+           -> Maybe (Set.Set ((Int, Int), (Int, Int)))
+      walk bd p dir seen
+        | not (inBounds bd p) = Just seen
+        | (p, dir) `Set.member` seen = Nothing
+        | otherwise =
+            let p' = p +. dir
+            in if inBounds bd p' && bd `at` p' == '#'
+                 then walk bd p (rot dir) seen
+                 else walk bd p' dir (Set.insert (p, dir) seen)
+
+  bd' <- lines <$> getContents
+  let Just (Just initx, inity) = find (isJust . fst) (zip (map (findIndex (== '^')) bd') [0..])
+  let makeBd = A.listArray ((0, 0), (length bd' - 1, length (head bd') - 1)) . concat
+
+  let normalPath = Set.toList $ Set.map fst $ fromJust $ walk (makeBd bd') (initx, inity) (0, -1) mempty
+  print $ length normalPath
+
+  let freePositions = normalPath
+  let makeObsBd (ox, oy) = makeBd $ zipWith fixrow [0..] bd'
+        where fixrow y row | y == oy = zipWith fix [0..] row
+                           | otherwise = row
+              fix x c | x == ox = '#'
+                      | otherwise = c
+  let valid p = p /= (initx, inity) && isNothing (walk (makeObsBd p) (initx, inity) (0, -1) mempty)
+  print $ length (filter valid freePositions)