Skip to content

Commit

Permalink
cleanup
Browse files Browse the repository at this point in the history
  • Loading branch information
@Javran
Javran committed Feb 27, 2024
1 parent 10fc417 commit 69bc480
Showing 1 changed file with 85 additions and 82 deletions.
167 changes: 85 additions & 82 deletions src/Javran/AdventOfCode/Y2023/Day22.hs
View file
Original file line number Diff line number Diff line change
@@ -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)

Expand All @@ -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:
Expand All @@ -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:
Expand All @@ -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)
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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

0 comments on commit 69bc480

Please sign in to comment.