Day 22

advent-of-code-2023.cabal

@@ -152,3 +152,10 @@ executable day21
     hs-source-dirs:     day21
     default-language:   Haskell2010
     default-extensions: LambdaCase
+
+executable day22
+    main-is:            Main.hs
+    other-modules:      Commons Part1 Part2
+    build-depends:      base ^>=4.15.1.0, containers, MissingH
+    hs-source-dirs:     day22
+    default-language:   Haskell2010

day22/Commons.hs

@@ -0,0 +1,59 @@
+module Commons where
+
+import Data.List.Utils (split)
+import GHC.IO.Handle (isEOF)
+import qualified Data.Map.Strict as M
+
+
+data Cube = Cube { z :: Int, y :: Int, x :: Int } deriving (Eq, Ord, Show)
+type Brick = [Cube]
+type Snapshot = M.Map (Int, Int, Int) Brick
+
+
+parseBrick :: [Int] -> [Int] -> Brick
+parseBrick [x1, y1, z1] [x2, y2, z2] = Cube {x = x1, y = y1, z = z1}:
+  if x1 < x2 then parseBrick [x1 + 1, y1, z1] [x2, y2, z2]
+  else if x1 > x2 then parseBrick [x1, y1, z1] [x2 + 1, y2, z2]
+  else if y1 < y2 then parseBrick [x1, y1 + 1, z1] [x2, y2, z2]
+  else if y1 > y2 then parseBrick [x1, y1, z1] [x2, y2 + 1, z2]
+  else if z1 < z2 then parseBrick [x1, y1, z1 + 1] [x2, y2, z2]
+  else if z1 > z2 then parseBrick [x1, y1, z1] [x2, y2, z2 + 1]
+  else []
+
+parseLine :: String -> [((Int, Int, Int), Brick)]
+parseLine line = let (start: end: _) = split "~" line
+                     parsedStart = map read $ split "," start
+                     parsedEnd = map read $ split "," end
+                     brick = parseBrick parsedStart parsedEnd
+                 in map (\ c -> ((z c, y c, x c), brick)) brick
+
+parseSnapshot :: [((Int, Int, Int), Brick)] -> IO Snapshot
+parseSnapshot otherBricks = do done <- isEOF
+                               if done
+                                  then return $ M.fromList otherBricks
+                                  else do line <- getLine
+                                          let brick = parseLine line
+                                          parseSnapshot (otherBricks ++ brick)
+
+parse :: IO Snapshot
+parse = parseSnapshot []
+
+
+getFalling :: Snapshot -> [((Int, Int, Int), Brick)]
+getFalling s = M.toList $ M.filter (\ b ->
+  let minZ = foldl (\ mz c -> min mz (z c)) maxBound b
+  in foldl (\ r c -> r && minZ > 1 && M.notMember (minZ - 1, y c, x c) s) True b) s
+
+getFell :: Snapshot -> [((Int, Int, Int), Brick)] -> [((Int, Int, Int), Brick)]
+getFell s = map (\ ((zk, yk, xk), v) ->
+  ((zk - 1, yk, xk), map (\ c -> Cube {z = z c - 1, y = y c, x = x c}) v))
+
+getPostFall :: Snapshot -> [((Int, Int, Int), Brick)] -> [((Int, Int, Int), Brick)] -> Snapshot
+getPostFall s falling fell = M.union (M.difference s $ M.fromList falling) (M.fromList fell)
+
+fall :: Snapshot -> Snapshot
+fall s =
+  let falling = getFalling s
+      fell = getFell s falling
+  in if null falling then s
+     else fall $ getPostFall s falling fell

day22/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+import Commons
+import qualified Part1
+import qualified Part2
+
+
+main = do snapshot <- parse
+          let afterFallSnapshot = fall snapshot
+          let part1Res = Part1.getDestroyables afterFallSnapshot
+          print $ length part1Res
+          let part2Res = Part2.getReactions afterFallSnapshot
+          print $ sum $ map length part2Res

day22/Part1.hs

@@ -0,0 +1,13 @@
+module Part1 where
+
+import Commons
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+
+
+canDestroy :: Snapshot -> Brick -> Bool
+canDestroy s b = let newSnapshot = M.difference s $ M.fromList $ map (\ c -> ((z c, y c, x c), b)) b
+                 in null $ getFalling newSnapshot
+
+getDestroyables :: Snapshot -> S.Set Brick
+getDestroyables s = S.fromList $ filter (canDestroy s) $ M.elems s

day22/Part2.hs

@@ -0,0 +1,23 @@
+module Part2 where
+
+import Commons
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Foldable (maximumBy)
+import Data.Function (on)
+
+
+getFutureFall' :: Snapshot -> S.Set Brick -> S.Set Brick
+getFutureFall' s sFell =
+  let falling = getFalling s
+  in if null falling then sFell
+     else let fell = getFell s falling
+              newSFell = S.union (S.difference sFell (S.fromList $ map snd falling)) $ S.fromList $ map snd fell
+          in getFutureFall' (getPostFall s falling fell) newSFell
+
+getFutureFall :: Snapshot -> Brick -> S.Set Brick
+getFutureFall s b = let newSnapshot = M.difference s $ M.fromList $ map (\ c -> ((z c, y c, x c), b)) b
+                    in getFutureFall' newSnapshot S.empty
+
+getReactions :: Snapshot -> [S.Set Brick]
+getReactions s = S.toList $ S.fromList $ map (getFutureFall s) $ M.elems s