day 22

aoc.sh

@@ -90,3 +90,6 @@ stack exec day20 < input/day20.input
 
 echo -e "${IRed}--- Day 21: Step Counter ---${Color_Off}"
 stack exec day21 < input/day21.input
+
+echo -e "${IYellow}--- Day 22: Sand Slabs ---${Color_Off}"
+stack exec day22 < input/day22.input

aoc2023.cabal

@@ -350,6 +350,8 @@ executable day21
 
 executable day22
   main-is: Day22.hs
+  other-modules:
+      Util.Parser
   hs-source-dirs:
       src
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -main-is Day22
@@ -460,6 +462,7 @@ test-suite spec
       TestDay19
       TestDay20
       TestDay21
+      TestDay22
       Paths_aoc2023
   autogen-modules:
       Paths_aoc2023

package.yaml

@@ -140,7 +140,7 @@ executables:
   day22:
     source-dirs:     src
     main:            Day22
-    other-modules:   []
+    other-modules:   [Util.Parser]
 
   day23:
     source-dirs:     src

src/Day22.hs

@@ -1,10 +1,103 @@
 module Day22 (main, part1, part2) where
 
+import Control.Arrow (Arrow ((&&&)))
+import Control.Monad.State (State, evalState, get, put)
+import Data.List (intersect, sortBy)
+import qualified Data.Map as M
+import qualified Text.Parsec as P
+import Util.Parser (Parser, parse)
+
+type Block = (Int, Int, Int)
+
+data Brick = Brick Block Block deriving (Show, Eq, Ord)
+
+blockP :: Parser Block
+blockP = do
+    x <- read <$> P.many1 P.digit <* P.char ','
+    y <- read <$> P.many1 P.digit <* P.char ','
+    z <- read <$> P.many1 P.digit
+    return (x, y, z)
+
+brickP :: Parser Brick
+brickP = do
+    a <- blockP <* P.string "~"
+    b <- blockP <* P.spaces
+    return $ Brick a b
+
+inputP :: Parser [Brick]
+inputP = P.many1 brickP <* P.eof
+
+below :: Brick -> Brick -> Bool
+below b@(Brick (_, _, z1) (_, _, z2)) b'@(Brick (_, _, z1') (_, _, z2')) = max z1 z2 == min z1' z2' - 1 && b /= b'
+
+hold :: Brick -> Brick -> Bool
+hold b b' = below b b' && not (null $ intersect (squares b) (squares b'))
+  where
+    squares (Brick (x1, y1, _) (x2, y2, _)) = [(x, y) | x <- [min x1 x2 .. max x1 x2], y <- [min y1 y2 .. max y1 y2]]
+
+blocked :: Brick -> [Brick] -> Bool
+blocked n m = bottom n || any (`hold` n) m
+  where
+    bottom (Brick (_, _, z1) (_, _, z2)) = min z1 z2 == 1
+
+move :: Brick -> Brick
+move (Brick (x1, y1, z1) (x2, y2, z2)) = Brick (x1, y1, z1 - 1) (x2, y2, z2 - 1)
+
+updatePlane :: [Brick] -> Brick -> [Brick]
+updatePlane ms m = (if blocked m ms then m else move m) : ms
+
+step :: [Brick] -> [Brick]
+step = reverse . foldl updatePlane [] . sortBricks
+  where
+    sortBricks :: [Brick] -> [Brick]
+    sortBricks = sortBy (\(Brick (_, _, z1) (_, _, z2)) (Brick (_, _, z3) (_, _, z4)) -> compare (min z1 z2) (min z3 z4))
+
+check :: [Brick] -> Bool
+check m = m == step m
+
+simulate :: [Brick] -> [Brick]
+simulate = until check step
+
+support :: [Brick] -> (M.Map Brick [Brick], M.Map Brick [Brick])
+support bs = (go &&& go') bs
+  where
+    go :: [Brick] -> M.Map Brick [Brick]
+    go [] = M.empty
+    go (b : bs') = M.insert b (filter (`hold` b) bs) $ go bs'
+    go' :: [Brick] -> M.Map Brick [Brick]
+    go' [] = M.empty
+    go' (b : bs') = M.insert b (filter (b `hold`) bs) $ go' bs'
+
+redundant :: [Brick] -> Int
+redundant bs = length $ filter (\(_, ss) -> all (\s -> length (supported M.! s) > 1) ss) $ M.toList supports
+  where
+    (supported, supports) = support bs
+
+type ChainState = State (M.Map Brick [Brick], M.Map Brick [Brick])
+
+chain :: Brick -> ChainState Int
+chain b = do
+    (supported, supports) <- get
+    if null (supported M.! b)
+        then do
+            put (M.map (filter (/= b)) supported, supports)
+            (+ 1) . sum <$> mapM chain (supports M.! b)
+        else return 0
+
+clear :: Brick -> ChainState ()
+clear b = do
+    (supported, supports) <- get
+    put (M.insert b [] supported, supports)
+    return ()
+
+reaction :: [Brick] -> Int
+reaction bs = sum $ map (\b -> (-1) + evalState (clear b >> chain b) (support bs)) bs
+
 part1 :: String -> String
-part1 = id
+part1 = show . redundant . simulate . parse inputP
 
 part2 :: String -> String
-part2 = const ""
+part2 = show . reaction . simulate . parse inputP
 
 solve :: String -> String
 solve input = "Part 1: " ++ part1 input ++ "\nPart 2: " ++ part2 input ++ "\n"

test/Main.hs

@@ -21,6 +21,7 @@ import TestDay18
 import TestDay19
 import TestDay20
 import TestDay21
+import TestDay22
 
 main :: IO ()
 main = do
@@ -45,3 +46,4 @@ main = do
     TestDay19.test
     TestDay20.test
     TestDay21.test
+    TestDay22.test

test/TestDay22.hs

@@ -0,0 +1,22 @@
+module TestDay22 (test) where
+
+import Day22
+import Test.Hspec
+
+input :: String
+input = "1,0,1~1,2,1\n0,0,2~2,0,2\n0,2,3~2,2,3\n0,0,4~0,2,4\n2,0,5~2,2,5\n0,1,6~2,1,6\n1,1,8~1,1,9"
+
+test1 :: Expectation
+test1 = part1 input `shouldBe` "5"
+
+test2 :: Expectation
+test2 = part2 input `shouldBe` "7"
+
+test :: IO ()
+test = hspec $ do
+    describe "day22" $ do
+        describe "part1" $ do
+            it "should work for the examples" test1
+
+        describe "part2" $ do
+            it "should work for the examples" test2