Done day 22

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index 0eda336be9bc34e934b06c6de592cc7b55379d24..3f78f06738298328ffe0ff520e58986409c2018d 100644 (file)
--- a/advent-of-code23.cabal
+++ b/advent-of-code23.cabal
@@ -221,3 +221,8 @@ executable advent21
   import: common-extensions, build-directives
   main-is: advent21/Main.hs
   build-depends: linear, containers, split
+
+executable advent22
+  import: common-extensions, build-directives
+  main-is: advent22/Main.hs
+  build-depends: linear, text, attoparsec, lens, containers

diff --git a/advent22/Main.hs b/advent22/Main.hs
new file mode 100644 (file)
index 0000000..87bdf6c
--- /dev/null
+++ b/advent22/Main.hs
@@ -0,0 +1,139 @@
+-- Writeup at https://work.njae.me.uk/2023/12/31/advent-of-code-2023-day-22/
+
+import AoC
+
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+import Data.Attoparsec.Text
+-- import Control.Applicative
+import Control.Lens
+import Linear
+-- import Linear.V2
+-- import Linear.V3
+import Data.List
+import Data.Function
+import qualified Data.Map as M
+import Data.Map ((!))
+import qualified Data.Set as S
+
+type Block = (V3 Int, V3 Int)
+
+type Support = M.Map Block (S.Set Block)
+
+intersectsXY :: (R2 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
+intersectsXY (a1, a2) (b1, b2) = 
+  not $ disjointX (a1, a2) (b1, b2) || disjointY (a1, a2) (b1, b2)
+
+intersectsXYZ :: (R3 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
+intersectsXYZ (a1, a2) (b1, b2) = 
+  not $ disjointX (a1, a2) (b1, b2) || disjointY (a1, a2) (b1, b2) 
+                                    || disjointZ (a1, a2) (b1, b2)
+
+disjointX :: (R1 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
+disjointY :: (R2 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
+disjointZ :: (R3 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
+disjointX (a1, a2) (b1, b2) = a2 ^. _x < b1 ^. _x || b2 ^. _x < a1 ^. _x
+disjointY (a1, a2) (b1, b2) = a2 ^. _y < b1 ^. _y || b2 ^. _y < a1 ^. _y
+disjointZ (a1, a2) (b1, b2) = a2 ^. _z < b1 ^. _z || b2 ^. _z < a1 ^. _z
+
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- TIO.readFile dataFileName
+      let unsortedBlocks = successfulParse text
+      let fallingBlocks = sortBy (compare `on` (^. _1 . _z)) unsortedBlocks
+      let blocks = dropBlocks fallingBlocks
+      let suppBy = makeSupportedBy blocks
+      let unsafes = disintegrateUnsafe suppBy
+      -- print blocks
+      print $ part1 blocks unsafes
+      print $ part2 suppBy unsafes
+
+part1 :: [Block] -> [Block] -> Int
+part1 blocks unsafes = length blocks - length unsafes
+
+part2 :: Support -> [Block] -> Int
+part2 suppBy unsafes = sum $ fmap (countFloating suppBy tSupport) unsafes
+  where dSupport = makeSupport suppBy
+        tSupport = transitiveSupport dSupport
+
+dropBlocks :: [Block] -> [Block]
+dropBlocks blocks = foldl' dropBlock [] blocks
+
+dropBlock :: [Block] -> Block -> [Block]
+dropBlock resting block = resting ++ [over both (^-^ (V3 0 0 fallDistance)) block]
+  where _2xy = alongside _xy _xy
+        blockPlane = block ^. _2xy
+        under = filter ((intersectsXY blockPlane) . (view _2xy)) resting
+        highestUnder = maxZ under
+        fallDistance = block ^. _1 . _z - highestUnder - 1
+
+maxZ :: [Block] -> Int
+maxZ [] = 0
+maxZ xs@(_:_) = maximum $ fmap (^. _2 . _z) xs
+
+supporters :: [Block] -> Block -> [Block]
+supporters blocks block = filter ((intersectsXYZ block) . overPlane) blocks
+  where overPlane c = let z = (c ^. _2 . _z) + 1 in c & both . _z .~ z
+
+-- disintegrateUnsafe :: [Block] -> [Block]
+-- disintegrateUnsafe blocks = 
+--   nub $ fmap head $ filter ((== 1) . length) $ fmap (supporters blocks) blocks
+
+disintegrateUnsafe :: Support -> [Block]
+disintegrateUnsafe = S.toList . S.unions . M.elems . M.filter ((== 1) . S.size)
+
+makeSupportedBy :: [Block] -> Support
+makeSupportedBy blocks = 
+  M.fromList [(b, S.fromList $ supporters blocks b) | b <- blocks]
+
+makeSupport :: Support -> Support
+makeSupport suppBy = inverted `M.union` base
+  where inverted = M.foldlWithKey' insertSupport M.empty suppBy 
+        insertSupport m b s = foldl' (\m' b' -> M.insertWith S.union b' (S.singleton b) m') m s
+        base = M.fromList [(b, S.empty) | b <- M.keys suppBy]
+
+transitiveSupport :: Support -> Support
+transitiveSupport dSupport = foldl' (transitiveSupportBlock dSupport) M.empty $ M.keys dSupport
+
+transitiveSupportBlock :: Support -> Support -> Block -> Support
+transitiveSupportBlock dSupport tSupport block
+  | block `M.member` tSupport = tSupport
+  | otherwise = M.insert block tSupporteds tSupport'
+  where supporteds = dSupport ! block
+        tSupport' = foldl' (transitiveSupportBlock dSupport) tSupport supporteds
+        tSupporteds = S.union supporteds $ S.unions $ S.map (tSupport' !) supporteds
+
+indirectGrounded :: Support -> Block -> Bool
+indirectGrounded _ (V3 _ _ 1, _) = True
+indirectGrounded suppBy block = 
+  any (indirectGrounded suppBy) $ S.toList $ suppBy ! block
+
+countFloating :: Support -> Support -> Block -> Int
+countFloating suppBy tSupport block = 
+  S.size $ S.filter (not . (indirectGrounded suppByRemoved)) (tSupport ! block)
+  where blockS = S.singleton block
+        suppByRemoved = M.map (S.\\ blockS) suppBy
+
+
+-- Parse the input file
+
+blocksP :: Parser [Block]
+blockP :: Parser Block
+vertexP :: Parser (V3 Int)
+
+blocksP = blockP `sepBy` endOfLine
+blockP = cubify <$> (vertexP <* "~") <*> vertexP
+  where cubify (V3 x1 y1 z1) (V3 x2 y2 z2) = 
+          ( (V3 (min x1 x2) (min y1 y2) (min z1 z2))
+          , (V3 (max x1 x2) (max y1 y2) (max z1 z2))
+          )
+
+vertexP = V3 <$> decimal <*> ("," *> decimal) <*> ("," *> decimal)
+
+successfulParse :: Text -> [Block]
+successfulParse input = 
+  case parseOnly blocksP input of
+    Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
+    Right matches -> matches
\ No newline at end of file