advent22/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2023/12/31/advent-of-code-2023-day-22/
   2
   3 import AoC
   4
   5 import Data.Text (Text)
   6 import qualified Data.Text.IO as TIO
   7 import Data.Attoparsec.Text
   8 -- import Control.Applicative
   9 import Control.Lens
  10 import Linear
  11 -- import Linear.V2
  12 -- import Linear.V3
  13 import Data.List
  14 import Data.Function
  15 import qualified Data.Map as M
  16 import Data.Map ((!))
  17 import qualified Data.Set as S
  18
  19 type Block = (V3 Int, V3 Int)
  20
  21 type Support = M.Map Block (S.Set Block)
  22
  23 intersectsXY :: (R2 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
  24 intersectsXY (a1, a2) (b1, b2) =
  25   not $ disjointX (a1, a2) (b1, b2) || disjointY (a1, a2) (b1, b2)
  26
  27 intersectsXYZ :: (R3 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
  28 intersectsXYZ (a1, a2) (b1, b2) =
  29   not $ disjointX (a1, a2) (b1, b2) || disjointY (a1, a2) (b1, b2)
  30                                     || disjointZ (a1, a2) (b1, b2)
  31
  32 disjointX :: (R1 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
  33 disjointY :: (R2 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
  34 disjointZ :: (R3 t, Ord a) => (t a, t a) -> (t a, t a) -> Bool
  35 disjointX (a1, a2) (b1, b2) = a2 ^. _x < b1 ^. _x || b2 ^. _x < a1 ^. _x
  36 disjointY (a1, a2) (b1, b2) = a2 ^. _y < b1 ^. _y || b2 ^. _y < a1 ^. _y
  37 disjointZ (a1, a2) (b1, b2) = a2 ^. _z < b1 ^. _z || b2 ^. _z < a1 ^. _z
  38
  39
  40 main :: IO ()
  41 main =
  42   do  dataFileName <- getDataFileName
  43       text <- TIO.readFile dataFileName
  44       let unsortedBlocks = successfulParse text
  45       let fallingBlocks = sortBy (compare `on` (^. _1 . _z)) unsortedBlocks
  46       let blocks = dropBlocks fallingBlocks
  47       let suppBy = makeSupportedBy blocks
  48       let unsafes = disintegrateUnsafe suppBy
  49       -- print blocks
  50       print $ part1 blocks unsafes
  51       print $ part2 suppBy unsafes
  52
  53 part1 :: [Block] -> [Block] -> Int
  54 part1 blocks unsafes = length blocks - length unsafes
  55
  56 part2 :: Support -> [Block] -> Int
  57 part2 suppBy unsafes = sum $ fmap (countFloating suppBy tSupport) unsafes
  58   where dSupport = makeSupport suppBy
  59         tSupport = transitiveSupport dSupport
  60
  61 dropBlocks :: [Block] -> [Block]
  62 dropBlocks blocks = foldl' dropBlock [] blocks
  63
  64 dropBlock :: [Block] -> Block -> [Block]
  65 dropBlock resting block = resting ++ [over both (^-^ (V3 0 0 fallDistance)) block]
  66   where -- _2xy = alongside _xy _xy
  67         -- blockPlane = block ^. _2xy
  68         blockPlane = over both (view _xy) block
  69         -- under = filter ((intersectsXY blockPlane) . (view _2xy)) resting
  70         under = filter ((intersectsXY blockPlane) . (over both (view _xy))) resting
  71         highestUnder = maxZ under
  72         fallDistance = block ^. _1 . _z - highestUnder - 1
  73
  74 maxZ :: [Block] -> Int
  75 maxZ [] = 0
  76 maxZ xs@(_:_) = maximum $ fmap (^. _2 . _z) xs
  77
  78 supporters :: [Block] -> Block -> [Block]
  79 supporters blocks block = filter ((intersectsXYZ block) . overPlane) blocks
  80   where overPlane c = let z = (c ^. _2 . _z) + 1 in c & both . _z .~ z
  81
  82 -- disintegrateUnsafe :: [Block] -> [Block]
  83 -- disintegrateUnsafe blocks =
  84 --   nub $ fmap head $ filter ((== 1) . length) $ fmap (supporters blocks) blocks
  85
  86 disintegrateUnsafe :: Support -> [Block]
  87 disintegrateUnsafe = S.toList . S.unions . M.elems . M.filter ((== 1) . S.size)
  88
  89 makeSupportedBy :: [Block] -> Support
  90 makeSupportedBy blocks =
  91   M.fromList [(b, S.fromList $ supporters blocks b) | b <- blocks]
  92
  93 makeSupport :: Support -> Support
  94 makeSupport suppBy = inverted `M.union` base
  95   where inverted = M.foldlWithKey' insertSupport M.empty suppBy
  96         insertSupport m b s = foldl' (\m' b' -> M.insertWith S.union b' (S.singleton b) m') m s
  97         base = M.fromList [(b, S.empty) | b <- M.keys suppBy]
  98
  99 transitiveSupport :: Support -> Support
 100 transitiveSupport dSupport = foldl' (transitiveSupportBlock dSupport) M.empty $ M.keys dSupport
 101
 102 transitiveSupportBlock :: Support -> Support -> Block -> Support
 103 transitiveSupportBlock dSupport tSupport block
 104   | block `M.member` tSupport = tSupport
 105   | otherwise = M.insert block tSupporteds tSupport'
 106   where supporteds = dSupport ! block
 107         tSupport' = foldl' (transitiveSupportBlock dSupport) tSupport supporteds
 108         tSupporteds = S.union supporteds $ S.unions $ S.map (tSupport' !) supporteds
 109
 110 indirectGrounded :: Support -> Block -> Bool
 111 indirectGrounded _ (V3 _ _ 1, _) = True
 112 indirectGrounded suppBy block =
 113   any (indirectGrounded suppBy) $ S.toList $ suppBy ! block
 114
 115 countFloating :: Support -> Support -> Block -> Int
 116 countFloating suppBy tSupport block =
 117   S.size $ S.filter (not . (indirectGrounded suppByRemoved)) (tSupport ! block)
 118   where blockS = S.singleton block
 119         suppByRemoved = M.map (S.\\ blockS) suppBy
 120
 121
 122 -- Parse the input file
 123
 124 blocksP :: Parser [Block]
 125 blockP :: Parser Block
 126 vertexP :: Parser (V3 Int)
 127
 128 blocksP = blockP `sepBy` endOfLine
 129 blockP = cubify <$> (vertexP <* "~") <*> vertexP
 130   where cubify (V3 x1 y1 z1) (V3 x2 y2 z2) =
 131           ( (V3 (min x1 x2) (min y1 y2) (min z1 z2))
 132           , (V3 (max x1 x2) (max y1 y2) (max z1 z2))
 133           )
 134
 135 vertexP = V3 <$> decimal <*> ("," *> decimal) <*> ("," *> decimal)
 136
 137 successfulParse :: Text -> [Block]
 138 successfulParse input =
 139   case parseOnly blocksP input of
 140     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 141     Right matches -> matches