diff --git a/src/Javran/AdventOfCode/Y2023/Day22.hs b/src/Javran/AdventOfCode/Y2023/Day22.hs index 279a078..5c9b6c9 100644 --- a/src/Javran/AdventOfCode/Y2023/Day22.hs +++ b/src/Javran/AdventOfCode/Y2023/Day22.hs @@ -1,32 +1,13 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-deprecations #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -fdefer-typed-holes #-} - module Javran.AdventOfCode.Y2023.Day22 () where -{- HLINT ignore -} - -import Control.Applicative import Control.Monad 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 -import GHC.Generics (Generic) import Javran.AdventOfCode.Prelude import Text.ParserCombinators.ReadP hiding (count, get, many) @@ -51,11 +32,15 @@ brickP = do pure (l, r) {- - Notes: I feel like a lot of assumptions can be made for this problem based on input data. - We'll explore a bit and see what we can find. + [Properties regarding input data] + + This section is just a bunch of properties I found while exploring the input data, + though not all of them are useful. - x and y ranges are fairly small - in fact: 0 <= x <= 9 && 0 <= y <= 9. + This suggests we can go with a dense representation. + - bricks appear to be chaging in only one dimension. or, for the pair: `x0,y0,z0-x1,y1,z1`, at least one of the below are true: @@ -74,17 +59,18 @@ brickP = do - len: brick length - ty: type of the brick, here are talking about orientation, could be x | y | z. - I'm guessing we sort by z of "l-part" and just start placing bricks in that order. - Though I'm not sure how to resolve order - if there are multiple bricks in the same z-bucket. + In the end we do not implement this alternative representation, as it seems unnecessary. + + - Input bricks are given with z-coordinate out of order. - Here we can probably verify that in such case nothing overlaps at lease on their bases - so the order of placing things does not matter. + So first thing we can sort by z-coordinate and insert those bricks in order. + (here we use z of "l-part" as it's the lowest of the two.) - Update: for all bricks whose lowest z-cooridinte line up, no overlaps are present, - meaning it doesn't matter in which order we place them. + I was worried how to resolve order of insertion when there are multiple bricks of the same z-order. + However this turned out not to be any concern - no bricks sharing same z-coordinate + were overlapping. - Update: now we've put together all bricks, we need to count bricks that should not be disintegrated. + [Part 1 notes] The criteria seems to be: @@ -93,6 +79,20 @@ brickP = do So here what we can do is to scan through bottom slice of all bricks and see what bricks are supporting it - if there is only one brick id, that brick id should not be disintegrated. + [Part 2 notes] + + We'll need to build up "A supports B" and "B is being supported by A" graphs, + then we can simulate the process. + + At a glance, this problem sounds like having a recursive structure but I can't quite make it work: + + Say, if we denote f(A) for the set of bricks that will drop if A is removed, + and if by removing A, B and C will both be dropping, f(B) and f(C) would not be + of much use if there are bricks that are supported by both and only B and C. + + But as the size of input data isn't very large, I believe simulation is still the way to go + and its correctness is easier to establish. + -} type Coord = (Int, Int) -- (x, y) @@ -103,15 +103,12 @@ insertBrick :: 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 - ) + , -- 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) + , IMM.singleton bkId supporters ) where -- a slice of the brick (horizontally cut) @@ -126,12 +123,9 @@ insertBrick bkId ((x0, y0, z0), (x1, y1, z1)) s = Nothing -> 1 Just (mx, _) -> mx + 1 - canInsert curZ = - if curZ <= 0 - then False - else - let sSlice = fromMaybe M.empty (s IM.!? curZ) - in M.disjoint bSlice sSlice + canInsert curZ = curZ > 0 && M.disjoint bSlice sSlice + where + sSlice = fromMaybe M.empty (s IM.!? curZ) finalZ = fix @@ -146,50 +140,51 @@ insertBrick bkId ((x0, y0, z0), (x1, y1, z1)) s = z <- [finalZ .. z1 - z0 + finalZ] pure (z, bSlice) + {- + Looks below the lowest z-plane of insertion + and finds out what bricks are supporting current one. + -} supporters :: IS.IntSet - supporters = - fromMaybe IS.empty do - sp <- s IM.!? (finalZ - 1) - pure $ IS.fromList $ mapMaybe (sp M.!?) (M.keys bSlice) + supporters = fromMaybe IS.empty do + sp <- s IM.!? (finalZ - 1) + pure $ IS.fromList $ mapMaybe (sp M.!?) (M.keys bSlice) {- - p2 notes: + Simulates the chain reaction for part 2. - We'll need to build up "A supports B" and "B is being supported by A" graphs, - then we can simulate the process. + > chainReaction supps revSupps removed q - This problem sounds like having a recursive structure but I'm not quite convinced: - say, if we denote f(A) for the set of blocks that will drop if A is removed, - and if by removing A, B and C will both be dropping, f(B) and f(C) would not be - of much use if there are blocks that are supported by both and only B and C. + - removed: brick ids in this set should be considered already removed. - I'm not saying it's not possible, but for sake of correctness we should try - to do the slow process first. + - q: keeps track of the chain reaction - items in the queue should be considered + but not necessarily removed if that brick is supported by bricks that are not removed. - Also note that all we care about are those support relations that we can - already get from putting all bricks together - maybe we can collect - those relations while putting bricks together? + Note that one brick may be enqueued multiple times due to one of its supporting brick + being removed - this is desired behavior as it allows this brick to be removed when + all of its supports are removed. -} - 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) - ) +chainReaction supps revSupps = fix \go removed -> \case + Seq.Empty -> removed + cur Seq.:<| q1 -> + let + shouldRemove = + -- forcefully remove or when all of its supports are gone + 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 + {- + Now bring into attention whatever current brick is supporting + as long as it's not removed. + Note that it's intentional that one brick could be enqueued multiple times + as its supporters are removed. + -} + filter (\b -> IS.notMember b removed) . IS.toList <$> revSupps IM.!? cur + in + go removed' (q1 <> Seq.fromList nexts) instance Solution Day22 where solutionRun _ SolutionContext {getInputS, answerShow} = do @@ -199,18 +194,26 @@ instance Solution Day22 where . lines <$> getInputS let - {- for supps: (k, vs) in it means forall v <- vs, k is supported by v. -} - (sFin, (zs, IMM.MonoidalIntMap supps)) = runWriter do + IMM.MonoidalIntMap supps = execWriter do + {- + for supps: (k, vs) in it means forall v <- vs, k is supported by v. + also we allow values to be empty sets - meaning size of supps is the same as input size. + -} foldM (\s (i, b) -> writer (insertBrick i b s)) mempty (zip [0 ..] xs) - (w, IMM.MonoidalIntMap revSupps) = execWriter do + (unsafes, 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) + [v] -> + -- for p1, v is unsafe to disintegrate if it is the only brick supporting u. + tell (IS.singleton v, mempty) _ -> pure () + -- for p2, build up reverse "support" relation for easy access. forM_ vs \v -> tell (mempty, IMM.singleton v (IS.singleton u)) - answerShow $ length xs - IS.size w - let sim x = IS.size (chainReaction supps revSupps (IS.singleton x) (Seq.fromList [x])) - 1 - answerShow $ sum (fmap sim (IM.keys supps)) + answerShow $ IM.size supps - IS.size unsafes + + answerShow $ + let countFall x = IS.size (chainReaction supps revSupps (IS.singleton x) (Seq.singleton x)) - 1 + in getSum $ foldMap (Sum . countFall) $ IS.toList unsafes