day 22 solved.

README.md

@@ -15,7 +15,7 @@ Solutions, scripting, and templates - all in one repo.
 | ☑ [Day 6](src/Javran/AdventOfCode/Y2023/Day6.hs) | ☑ [Day 7](src/Javran/AdventOfCode/Y2023/Day7.hs) | ☑ [Day 8](src/Javran/AdventOfCode/Y2023/Day8.hs) | ☑ [Day 9](src/Javran/AdventOfCode/Y2023/Day9.hs) | ☑ [Day 10](src/Javran/AdventOfCode/Y2023/Day10.hs) |
 | ☑ [Day 11](src/Javran/AdventOfCode/Y2023/Day11.hs) | ☑ [Day 12](src/Javran/AdventOfCode/Y2023/Day12.hs) | ☑ [Day 13](src/Javran/AdventOfCode/Y2023/Day13.hs) | ☑ [Day 14](src/Javran/AdventOfCode/Y2023/Day14.hs) | ☑ [Day 15](src/Javran/AdventOfCode/Y2023/Day15.hs) |
 | ☑ [Day 16](src/Javran/AdventOfCode/Y2023/Day16.hs) | ☑ [Day 17](src/Javran/AdventOfCode/Y2023/Day17.hs) | ☑ [Day 18](src/Javran/AdventOfCode/Y2023/Day18.hs) | ☑ [Day 19](src/Javran/AdventOfCode/Y2023/Day19.hs) | ☑ [Day 20](src/Javran/AdventOfCode/Y2023/Day20.hs) |
-| ☐ [Day 21](src/Javran/AdventOfCode/Y2023/Day21.hs) | ☐ [Day 22](src/Javran/AdventOfCode/Y2023/Day22.hs) |  |  |  |
+| ☐ [Day 21](src/Javran/AdventOfCode/Y2023/Day21.hs) | ☑ [Day 22](src/Javran/AdventOfCode/Y2023/Day22.hs) |  |  |  |
 
 ### 2022
 

data/testdata/2023/day/22/example.expect.txt

@@ -0,0 +1,2 @@
+5
+7

src/Javran/AdventOfCode/Y2023/Day22.hs

@@ -14,13 +14,15 @@ import Control.Monad.Writer.CPS
 import Data.Char
 import Data.Function
 import Data.Function.Memoize (memoFix)
+import qualified Data.IntMap.Monoidal.Strict as IMM
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
 import Data.List
 import Data.List.Split hiding (sepBy)
 import qualified Data.Map.Strict as M
 import Data.Monoid hiding (First, Last)
 import Data.Semigroup
+import qualified Data.Sequence as Seq
 import qualified Data.Set as S
 import qualified Data.Text as T
 import qualified Data.Vector as V
@@ -96,8 +98,21 @@ brickP = do
 type Coord = (Int, Int) -- (x, y)
 type St = IM.IntMap (M.Map Coord Int) -- z-index to 2-d coord to brick reference number.
 
-insertBrick :: Int -> Brick -> St -> (St, IM.IntMap Int)
-insertBrick bkId ((x0, y0, z0), (x1, y1, z1)) s = (IM.unionWith M.union s extra, IM.singleton bkId finalZ)
+insertBrick ::
+  Int ->
+  Brick ->
+  St ->
+  ( St
+  , ( -- where is the final z-coordinate for this brick
+      IM.IntMap Int
+    , -- a (k,vs) in it means forall v <- vs, k is supported by v.
+      IMM.MonoidalIntMap IS.IntSet
+    )
+  )
+insertBrick bkId ((x0, y0, z0), (x1, y1, z1)) s =
+  ( IM.unionWith M.union s extra
+  , (IM.singleton bkId finalZ, IMM.singleton bkId supporters)
+  )
   where
     -- a slice of the brick (horizontally cut)
     bSlice :: M.Map Coord Int
@@ -117,6 +132,7 @@ insertBrick bkId ((x0, y0, z0), (x1, y1, z1)) s = (IM.unionWith M.union s extra,
         else
           let sSlice = fromMaybe M.empty (s IM.!? curZ)
            in M.disjoint bSlice sSlice
+
     finalZ =
       fix
         ( \go curZ ->
@@ -130,6 +146,12 @@ insertBrick bkId ((x0, y0, z0), (x1, y1, z1)) s = (IM.unionWith M.union s extra,
       z <- [finalZ .. z1 - z0 + finalZ]
       pure (z, bSlice)
 
+    supporters :: IS.IntSet
+    supporters =
+      fromMaybe IS.empty do
+        sp <- s IM.!? (finalZ - 1)
+        pure $ IS.fromList $ mapMaybe (sp M.!?) (M.keys bSlice)
+
 {-
   p2 notes:
 
@@ -150,26 +172,45 @@ insertBrick bkId ((x0, y0, z0), (x1, y1, z1)) s = (IM.unionWith M.union s extra,
 
  -}
 
+chainReaction :: IM.IntMap IS.IntSet -> IM.IntMap IS.IntSet -> IS.IntSet -> Seq.Seq Int -> IS.IntSet
+chainReaction supps revSupps =
+  fix
+    ( \go removed -> \case
+        Seq.Empty -> removed
+        cur Seq.:<| q1 ->
+          let
+            shouldRemove =
+              IS.member cur removed
+                || IS.null (IS.difference (fromMaybe IS.empty (supps IM.!? cur)) removed)
+            removed' = (if shouldRemove then IS.insert cur else id) removed
+            nexts = fromMaybe [] do
+              guard shouldRemove
+              us <- revSupps IM.!? cur
+              pure $ IS.toList us
+           in
+            go removed' (q1 <> Seq.fromList nexts)
+    )
+
 instance Solution Day22 where
-  solutionSolved _ = False
   solutionRun _ SolutionContext {getInputS, answerShow} = do
     xs <-
       sortOn (\((_, _, z), _) -> z)
         . fmap (consumeOrDie brickP)
         . lines
         <$> getInputS
-    let (sFin, zs) = runWriter do
-          foldM (\s (i, b) -> writer (insertBrick i b s)) mempty (zip [0 ..] xs)
-        w = execWriter do
-          forM_ (IM.toAscList zs) \(curBk, zBase) -> do
-            let bSlice = M.filter (== curBk) (sFin IM.! zBase)
-            case sFin IM.!? (zBase - 1) of
-              Nothing -> pure ()
-              Just supp -> do
-                let
-                  supporters = IS.fromList $ mapMaybe (\loc -> supp M.!? loc) $ M.keys bSlice
-                when (IS.size supporters == 1) do
-                  tell supporters
+    let
+      {- for supps: (k, vs) in it means forall v <- vs, k is supported by v.  -}
+      (sFin, (zs, IMM.MonoidalIntMap supps)) = runWriter do
+        foldM (\s (i, b) -> writer (insertBrick i b s)) mempty (zip [0 ..] xs)
+      (w, IMM.MonoidalIntMap revSupps) = execWriter do
+        forM_ (IM.toList supps) \(u, vsPre) -> do
+          let vs = IS.toList vsPre
+          case vs of
+            [v] -> tell (IS.singleton v, mempty)
+            _ -> pure ()
+          forM_ vs \v ->
+            tell (mempty, IMM.singleton v (IS.singleton u))
 
     answerShow $ length xs - IS.size w
-    print (let l = length xs in l)
+    let sim x = IS.size (chainReaction supps revSupps (IS.singleton x) (Seq.fromList [x])) - 1
+    answerShow $ sum (fmap sim (IM.keys supps))