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         under = filter ((intersectsXY blockPlane) . (view _2xy)) resting
  69         highestUnder = maxZ under
  70         fallDistance = block ^. _1 . _z - highestUnder - 1
  71
  72 maxZ :: [Block] -> Int
  73 maxZ [] = 0
  74 maxZ xs@(_:_) = maximum $ fmap (^. _2 . _z) xs
  75
  76 supporters :: [Block] -> Block -> [Block]
  77 supporters blocks block = filter ((intersectsXYZ block) . overPlane) blocks
  78   where overPlane c = let z = (c ^. _2 . _z) + 1 in c & both . _z .~ z
  79
  80 -- disintegrateUnsafe :: [Block] -> [Block]
  81 -- disintegrateUnsafe blocks =
  82 --   nub $ fmap head $ filter ((== 1) . length) $ fmap (supporters blocks) blocks
  83
  84 disintegrateUnsafe :: Support -> [Block]
  85 disintegrateUnsafe = S.toList . S.unions . M.elems . M.filter ((== 1) . S.size)
  86
  87 makeSupportedBy :: [Block] -> Support
  88 makeSupportedBy blocks =
  89   M.fromList [(b, S.fromList $ supporters blocks b) | b <- blocks]
  90
  91 makeSupport :: Support -> Support
  92 makeSupport suppBy = inverted `M.union` base
  93   where inverted = M.foldlWithKey' insertSupport M.empty suppBy
  94         insertSupport m b s = foldl' (\m' b' -> M.insertWith S.union b' (S.singleton b) m') m s
  95         base = M.fromList [(b, S.empty) | b <- M.keys suppBy]
  96
  97 transitiveSupport :: Support -> Support
  98 transitiveSupport dSupport = foldl' (transitiveSupportBlock dSupport) M.empty $ M.keys dSupport
  99
 100 transitiveSupportBlock :: Support -> Support -> Block -> Support
 101 transitiveSupportBlock dSupport tSupport block
 102   | block `M.member` tSupport = tSupport
 103   | otherwise = M.insert block tSupporteds tSupport'
 104   where supporteds = dSupport ! block
 105         tSupport' = foldl' (transitiveSupportBlock dSupport) tSupport supporteds
 106         tSupporteds = S.union supporteds $ S.unions $ S.map (tSupport' !) supporteds
 107
 108 indirectGrounded :: Support -> Block -> Bool
 109 indirectGrounded _ (V3 _ _ 1, _) = True
 110 indirectGrounded suppBy block =
 111   any (indirectGrounded suppBy) $ S.toList $ suppBy ! block
 112
 113 countFloating :: Support -> Support -> Block -> Int
 114 countFloating suppBy tSupport block =
 115   S.size $ S.filter (not . (indirectGrounded suppByRemoved)) (tSupport ! block)
 116   where blockS = S.singleton block
 117         suppByRemoved = M.map (S.\\ blockS) suppBy
 118
 119
 120 -- Parse the input file
 121
 122 blocksP :: Parser [Block]
 123 blockP :: Parser Block
 124 vertexP :: Parser (V3 Int)
 125
 126 blocksP = blockP `sepBy` endOfLine
 127 blockP = cubify <$> (vertexP <* "~") <*> vertexP
 128   where cubify (V3 x1 y1 z1) (V3 x2 y2 z2) =
 129           ( (V3 (min x1 x2) (min y1 y2) (min z1 z2))
 130           , (V3 (max x1 x2) (max y1 y2) (max z1 z2))
 131           )
 132
 133 vertexP = V3 <$> decimal <*> ("," *> decimal) <*> ("," *> decimal)
 134
 135 successfulParse :: Text -> [Block]
 136 successfulParse input =
 137   case parseOnly blocksP input of
 138     Left  _err -> [] -- TIO.putStr $ T.pack $ parseErrorPretty err
 139     Right matches -> matches