Day 22 was definitely a day of two halves. Part 1 was all about coordinate geometry, and part 2 was all about graph processing.

Representation and utilities

Given just two points for a block, all the blocks are cuboids. This makes some of the geometry easier.

I represent a Block as a pair of V3 elements. When parsing the input file, I make sure that each element of the first V3 is smaller than the elements in the second V3.

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)

I also need to know when two blocks intersect. I can easily say when blocks are disjoint in each dimension:

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

If two blocks are disjoint in x or disjoint in y, their x-y planes don't intersect. Similarly, if the blocks are disjoint in any of the three x, y, z dimensions, they don't intersect.

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)

Finally, I have a structure for keeping track what what blocks support what blocks (or what blocks are supported by what blocks).

type Support = M.Map Block (S.Set Block)

Part 1

All the results needed for part 1 are also needed for part 2, so I create them up front.

The first thing to do is to drop all the blocks and see where they land. I do that by sorting the blocks by lowest z value and dropping them one by one, building up a set of resting blocks as I go.

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

dropBlocks :: [Block] -> [Block]
dropBlocks blocks = foldl' dropBlock [] blocks 

To drop one block, I find all the resting blocks that intersect this block's x-y plane. This block falls until it's lowest z is one higher than the highest z of those other 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

Once all the blocks have fallen, I can find the supporters of each block. For each potential supporter, I create a volume that has the same x-y extent as the supporter, but z one higher than the block. If that volume intersects this block, the the potential supporter is an actual supporter.

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

I can find the supporters for all blocks, and record them.

makeSupportedBy :: [Block] -> Support
makeSupportedBy blocks = 
  M.fromList [(b, S.fromList $ supporters blocks b) | b <- blocks]

If a block has exactly one supporter, that supporter is unsafe to disintegrate.

disintegrateUnsafe :: Support -> [Block]
disintegrateUnsafe = S.toList . S.unions . M.elems . M.filter ((== 1) . S.size)

All of that makes part 1 trivial.

part1 blocks unsafes = length blocks - length unsafes

Part 2

For part 2, I need to know what blocks are supported by a particular block, and what blocks are still supported if a particular block disappears.

Given a supportedBy map, I can reverse the directions of the relationships to produce a map that shows which blocks are directly supported by a given block.

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]

In the interests of efficiency, I find the transitive closure of that map, to show the blocks that are directly or undirectly supported by a given block.

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

Going back to the supportedBy map, I can use that to determine if a block is still supported. A block is indirectly supported by the ground if it is on ground, or if any of its supporting blocks are indirectly supported by the ground.

indirectGrounded :: Support -> Block -> Bool
indirectGrounded _ (V3 _ _ 1, _) = True
indirectGrounded suppBy block = 
  any (indirectGrounded suppBy) $ S.toList $ suppBy ! block

If I remove a block, I can count the number of floating blocks it leaves. I remove the block from all lists of supporters and see which blocks are still indirectly grounded.  I use the transitively-supporting map above to limit how many blocks I consider, as the full input has several separate "towers" of blocks.

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

And that gives me part 2: add up the floating blocks after the removal of each unsafe one.

part2 :: Support -> [Block] -> Int
part2 suppBy unsafes = sum $ fmap (countFloating suppBy tSupport) unsafes
  where dSupport = makeSupport suppBy
        tSupport = transitiveSupport dSupport

Code

You can get the code from my locally-hosted Git repo, or from Gitlab.