1 files changed, 52 insertions(+), 12 deletions(-)

M 2023/14.hs

@@ 49,6 49,10 @@ inBounds (Grid _ ((minX, minY),(maxX, maxY))) (x,y) =
 bounds :: Grid a -> (Pos, Pos)
 bounds (Grid _ b) = b
 
+renderGrid :: Grid a -> (Maybe a -> Char) -> String
+renderGrid (Grid m ((minX, minY),(maxX, maxY))) r =
+  concat $ [[ r $ Map.lookup (x,y) m | x <-[minX..maxX] ] ++ "\n" | y <- [minY..maxY] ]
+
 type Parse = Grid Rock
 parser :: Parser Parse
 parser = parseGrid rock


@@ 56,30 60,66 @@ parser = parseGrid rock
            <|> char '#' $> Just Cube
            <|> char 'O' $> Just Round
 
-tiltNorth :: Grid Rock -> Pos -> Int
-tiltNorth g (x,y) =
-  let (_, (_, mY)) = bounds g in
-  mY - f 0 (pred y)
+roundRocks :: Grid Rock -> [Pos]
+roundRocks (Grid rs _) = Map.foldlWithKey f [] rs
+  where f acc p Round = p:acc
+        f acc _ Cube = acc
+
+north :: Grid Rock -> Pos -> Pos
+north g (x,y) = (x, succ $ f 0 (pred y))
   where f acc 0 = acc
         f acc y = case lookupGrid g (x,y) of
                     Nothing -> f acc (pred y)
                     Just Cube -> y + acc
                     Just Round -> f (succ acc) (pred y)
 
-roundRocks :: Grid Rock -> [Pos]
-roundRocks (Grid rs _) = Map.foldlWithKey f [] rs
-  where f acc p Round = p:acc
-        f acc _ Cube = acc
+east :: Grid Rock -> Pos -> Pos
+east g@(Grid _ (_, (mX, _))) (x,y) = (pred $ f 0 (succ x), y)
+  where f acc x | x > mX = succ $ mX - acc
+        f acc x | otherwise = case lookupGrid g (x,y) of
+                    Nothing -> f acc (succ x)
+                    Just Cube -> x - acc
+                    Just Round -> f (succ acc) (succ x)
+
+south :: Grid Rock -> Pos -> Pos
+south g@(Grid _ (_, (_, mY))) (x,y) = (x, pred $ f 0 (succ y))
+  where f acc y | y > mY = succ $ mY - acc
+        f acc y | otherwise = case lookupGrid g (x,y) of
+                    Nothing -> f acc (succ y)
+                    Just Cube -> y - acc
+                    Just Round -> f (succ acc) (succ y)
+
+west :: Grid Rock -> Pos -> Pos
+west g (x,y) = (succ $ f 0 (pred x), y)
+  where f acc 0 = acc
+        f acc x = case lookupGrid g (x,y) of
+                    Nothing -> f acc (pred x)
+                    Just Cube -> x + acc
+                    Just Round -> f (succ acc) (pred x)
+
+tilt :: (Grid Rock -> Pos -> Pos) -> Grid Rock -> Grid Rock
+tilt t g@(Grid !rs b) = Grid (Map.foldlWithKey f Map.empty rs) b
+  where f rs' p Round = Map.insert (t g p) Round rs'
+        f rs' p Cube = Map.insert p Cube rs'
+
+load :: Grid Rock -> Int
+load g@(Grid _ (_, (_, mY))) = sum $ [ succ $ mY - y | (_, y) <- roundRocks g ]
 
 partA :: Parse -> Int
-partA g = sum $ fmap (tiltNorth g) $ roundRocks g
+partA = load . tilt north
 
---partB :: Parse -> Parse
---partB = id
+partB :: Parse -> Int
+partB = f 0
+  where r Nothing = '.'
+        r (Just Cube) = '#'
+        r (Just Round) = 'O'
+        f n g | n == 1000000000 = load g
+        f n g | otherwise = f (succ n) (cycle g)
+        cycle = tilt east . tilt south . tilt west . tilt north
 
 main :: IO ()
 main = with parser $ do
   run' "14.example" "a example" partA 136
   run' "14.input" "a input" partA 106378
-  --run "14.example" "b example" partB
+  run "14.example" "b example" partB
   --run "14.input" "b input" partB