From bc60872c2c2b7472e1f51fd3ebd6051cc6b407f0 Mon Sep 17 00:00:00 2001
From: Jordan Doyle <jordan@doyle.la>
Date: Fri, 29 Dec 2023 19:43:51 +0000
Subject: [PATCH] Add day 22

---
 2023/22.hs | 73 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 README     |  9 +++++++++
 2 files changed, 82 insertions(+)
 create mode 100755 2023/22.hs

diff --git a/2023/22.hs b/2023/22.hs
new file mode 100755
index 0000000..1d39150
--- /dev/null
+++ b/2023/22.hs
@@ -0,0 +1,73 @@
+#!/usr/bin/env nix-shell
+#!nix-shell --pure -i "runghc -- -i../" -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [ ])"
+
+import Aoc (readAndParseStdin)
+import Data.Bifunctor (Bifunctor (first))
+import Data.List (sortBy)
+import Data.Ord (Down (Down), comparing)
+import Text.Parsec (char, digit, endBy, many1, (<|>))
+import Text.Parsec.String (Parser)
+
+main = do
+  (input, _) <- first sortBricks . dropBricks <$> readAndParseStdin parser
+  print $ part1 input
+  print $ part2 input
+
+part1 :: [Brick] -> Int
+part1 input = length $ findNonLoadBearing input
+  where
+    findNonLoadBearing input = filter (flip all input . isNonLoadBearing) input
+    supportedCount y = length $ filter (`isSupporting` y) input
+    isNonLoadBearing x y = not (x `isSupporting` y) || supportedCount y > 1
+
+part2 :: [Brick] -> Int
+part2 input = sum $ map (snd . dropBricks . dropIndex input) [0 .. length input - 1]
+  where
+    dropIndex input i = take i input ++ drop (i + 1) input
+
+-- drops bricks until they're all settled
+dropBricks :: [Brick] -> ([Brick], Int)
+dropBricks = foldl processBrick ([], 0)
+  where
+    processBrick (acc, n) x =
+      let (x', n') = dropUntilSupported acc x 0
+       in (x' : acc, n + min n' 1)
+    dropUntilSupported acc x n =
+      if isSupported acc x
+        then (x, n)
+        else dropUntilSupported acc (decrementZ x) (n + 1)
+    isSupported acc x = any (`isSupporting` x) acc || findBaseZ x == 1
+    decrementZ (Brick a b) = Brick (a {z = z a - 1}) (b {z = z b - 1})
+    findBaseZ (Brick a b) = min (z a) (z b)
+
+-- checks if a is supporting b
+isSupporting :: Brick -> Brick -> Bool
+isSupporting a@(Brick a1 a2) b@(Brick b1 b2) =
+  let (minX1, maxX1) = (min (x a1) (x a2), max (x a1) (x a2))
+      (minY1, maxY1) = (min (y a1) (y a2), max (y a1) (y a2))
+      (minZ1, maxZ1) = (min (z a1) (z a2), max (z a1) (z a2))
+      (minX2, maxX2) = (min (x b1) (x b2), max (x b1) (x b2))
+      (minY2, maxY2) = (min (y b1) (y b2), max (y b1) (y b2))
+      (minZ2, maxZ2) = (min (z b1) (z b2), max (z b1) (z b2))
+      zSupport = minZ2 == (maxZ1 + 1)
+      xOverlap = not (maxX1 < minX2 || maxX2 < minX1)
+      yOverlap = not (maxY1 < minY2 || maxY2 < minY1)
+   in a /= b && zSupport && xOverlap && yOverlap
+
+-- sorts bricks in ascending order of Z axis
+sortBricks :: [Brick] -> [Brick]
+sortBricks = sortBy (\(Brick a1 a2) (Brick b1 b2) -> compare (min (z a1) (z a2)) (min (z b1) (z b2)))
+
+parser :: Parser [Brick]
+parser = sortBricks <$> parseBrick `endBy` char '\n'
+  where
+    parseBrick = Brick <$> parseCoord <*> (char '~' *> parseCoord)
+    parseCoord = do
+      x <- read <$> many1 digit <* char ','
+      y <- read <$> many1 digit <* char ','
+      z <- read <$> many1 digit
+      return $ Coord {x, y, z}
+
+data Coord = Coord {x :: Int, y :: Int, z :: Int} deriving (Show, Eq)
+
+data Brick = Brick Coord Coord deriving (Show, Eq)
diff --git a/README b/README
index 0299bd5..30b31ac 100644
--- a/README
+++ b/README
@@ -27,4 +27,13 @@
 |       11 | Haskell  |
 |       12 | Rust     |
 |       13 | Haskell  |
+|       14 | Haskell  |
+|       15 | Haskell  |
+|       16 | Haskell  |
+|       17 | Rust     |
+|       18 | Haskell  |
+|       19 | Haskell  |
+|       20 | Haskell  |
+|       21 | Rust     |
+|       22 | Haskell  |
 +---------------------+
--
libgit2 1.7.2