From 5e886d892c0bef76b3f0fbac7de1001e75dabebb Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Sun, 31 Dec 2023 15:06:00 +0000 Subject: [PATCH] Done day 22 --- advent-of-code23.cabal | 5 ++ advent22/Main.hs | 139 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 144 insertions(+) create mode 100644 advent22/Main.hs diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal index 0eda336..3f78f06 100644 --- 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 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 -- 2.34.1