Day 17

Y2022.cabal

@@ -50,6 +50,7 @@ library
         Days.D14
         Days.D15
         Days.D16
+        Days.D17
     build-depends:
         bytestring
       , either
@@ -58,6 +59,7 @@ library
       , heap                    ^>=1.0.4
       , lens
       , megaparsec              ^>=9.4.0
+      , monad-loops             ^>=0.4.3
       , mtl
       , parser-combinators
       , text

app/Main.hs

@@ -24,6 +24,7 @@ paths =
     , "./data/14.in"
     , "./data/15.in"
     , "./data/16.in"
+    , "./data/17.in"
     ]
 
 solutions :: [(Int, Day, FilePath)]

bench/Bench.hs

@@ -23,6 +23,7 @@ paths =
     , "./data/14.in"
     , "./data/15.in"
     , "./data/16.in"
+    , "./data/17.in"
     ]
 
 solutions :: [(Integer, [Day], FilePath)]

data/17.in

@@ -0,0 +1 @@
+>>><<><>><<<>><>>><<<>>><<<><<<>><>><<>>

src/Days/D17.hs

@@ -0,0 +1,246 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Days.D17 where
+
+import Common
+import Control.Monad (foldM, liftM2)
+import Data.IntSet qualified as IntSet
+import Data.List (uncons)
+import Data.Map qualified as Map
+import Data.Maybe (fromJust)
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Tuple.Extra (uncurry3)
+
+data V2 = V2 !Int !Int deriving (Eq, Ord)
+
+instance Num V2 where
+  (+) (V2 a b) (V2 c d) = V2 (a + c) (b + d)
+  (*) = undefined
+  abs (V2 a b) = V2 (abs a) (abs b)
+  signum (V2 a b) = V2 (signum a) (signum b)
+  fromInteger = undefined
+  negate (V2 a b) = V2 (negate a) (negate b)
+
+type Formation = Set V2
+
+type Jet = Formation -> Formation
+
+setify :: [String] -> Formation
+setify =
+  Set.fromList
+    . concat
+    . zipWith f [0 ..]
+    . reverse
+  where
+    f :: Int -> String -> [V2]
+    f row =
+      map (V2 row . fst)
+        . filter ((/= '.') . snd)
+        . zip [0 ..]
+
+rocks :: [Formation]
+rocks =
+  map
+    setify
+    [ ["####"],
+      [ ".#.",
+        "###",
+        ".#."
+      ],
+      [ "..#",
+        "..#",
+        "###"
+      ],
+      [ "#",
+        "#",
+        "#",
+        "#"
+      ],
+      [ "##",
+        "##"
+      ]
+    ]
+
+translate :: V2 -> Formation -> Formation
+translate = Set.mapMonotonic . (+)
+
+left :: Formation -> Formation
+left = translate (-V2 0 1)
+
+right :: Formation -> Formation
+right = translate (V2 0 1)
+
+down :: Formation -> Formation
+down = translate (-V2 1 0)
+
+formationHeight :: Formation -> Int
+formationHeight = Set.findMax . Set.map (\(V2 a _) -> a)
+
+data CachedFormation = CFormation
+  { height :: Int,
+    baseHeight :: Int,
+    formation :: Formation
+  }
+  deriving (Eq, Ord)
+
+mkCachedFormation :: Formation -> CachedFormation
+mkCachedFormation f =
+  CFormation
+    { formation = f,
+      height = formationHeight f,
+      baseHeight = 0
+    }
+
+addRock :: Formation -> CachedFormation -> CachedFormation
+addRock rock CFormation {..} =
+  CFormation
+    { formation = Set.union formation rock,
+      height = max height (formationHeight rock),
+      baseHeight = baseHeight
+    }
+
+fullHeight :: CachedFormation -> Int
+fullHeight CFormation {..} = height + baseHeight
+
+simulate :: [Char] -> [CachedFormation]
+simulate jets =
+  let jetsCycle = cycle . map dir $ init jets
+      rockCycle = cycle rocks
+      groundLevel = mkCachedFormation $ Set.fromList [V2 0 x | x <- [0 .. 6]]
+   in map fst
+        . scanl
+          ( \state@(cachedFormation, _) ->
+              simFall state . translate (V2 (height cachedFormation + 4) 2)
+          )
+          (groundLevel, jetsCycle)
+        $ rockCycle
+  where
+    simFall ::
+      (CachedFormation, [Jet]) ->
+      Formation ->
+      (CachedFormation, [Jet])
+    simFall (settled@CFormation {..}, jetsCycle) rock =
+      let (jet, jetsCycle') = fromJust $ uncons jetsCycle
+          moveValid = liftM2 (&&) inside (Set.disjoint formation)
+          jetted = select (jet rock) rock moveValid
+          fallen = down jetted
+       in if moveValid fallen
+            then simFall (settled, jetsCycle') fallen
+            else
+              ( level . prune $ addRock jetted settled,
+                jetsCycle'
+              )
+
+    dir :: Char -> Formation -> Formation
+    dir '>' = right
+    dir '<' = left
+    dir _ = error "Invalid Direction"
+
+    inside :: Formation -> Bool
+    inside = Set.null . Set.filter (\(V2 _ y) -> y < 0 || y >= 7)
+
+    select :: a -> a -> (a -> Bool) -> a
+    select a b predicate = if predicate a then a else b
+
+level :: CachedFormation -> CachedFormation
+level CFormation {..} =
+  let baseLevel = Set.findMin $ Set.mapMonotonic (\(V2 x _) -> x) formation
+   in CFormation
+        { formation = translate (-V2 baseLevel 0) formation,
+          height = height - baseLevel,
+          baseHeight = baseHeight + baseLevel
+        }
+
+prune :: CachedFormation -> CachedFormation
+prune CFormation {..} =
+  let origin = V2 (height + 1) 0
+   in CFormation
+        { formation = go [origin] (IntSet.singleton $ pointToInt origin) [],
+          height = height,
+          baseHeight = baseHeight
+        }
+  where
+
+    pointToInt :: V2 -> Int
+    pointToInt (V2 x y) = x * 7 + y
+
+    go [] _ result = Set.fromList result
+    go active_ seen_ result_ =
+      let adjacent (V2 x y) =
+            [V2 (x - 1) y]
+              ++ [V2 x (y - 1) | y > 0]
+              ++ [V2 x (y + 1) | y < 6]
+       in uncurry3 go
+            . foldr
+              ( \p (active, seen, result) ->
+                  if Set.member p formation
+                    then (active, seen, p : result)
+                    else (p : active, IntSet.insert (pointToInt p) seen, result)
+              )
+              ([], seen_, result_)
+            . filter (\p -> not $ IntSet.member (pointToInt p) seen_)
+            . concatMap adjacent
+            $ active_
+
+data Cycle = Cycle
+  { startIdx :: Integer,
+    repeatIdx :: Integer,
+    cycleHeight :: Integer
+  }
+
+unwrapLeft :: Either a b -> a
+unwrapLeft (Left a) = a
+unwrapLeft _ = error "unwrapLeft called with Right"
+
+findCycle :: [CachedFormation] -> Cycle
+findCycle =
+  unwrapLeft
+    . foldM
+      ( \prevStates (index, CFormation {..}) ->
+          let key = (height, formation)
+              value = (index, toInteger baseHeight)
+           in case Map.lookup key prevStates of
+                Nothing -> Right $ Map.insert key value prevStates
+                Just cycleStart ->
+                  Left $
+                    Cycle
+                      { startIdx = fst cycleStart,
+                        repeatIdx = index,
+                        cycleHeight = toInteger baseHeight - snd cycleStart
+                      }
+      )
+      Map.empty
+    . zip [1 ..]
+
+fastHeightAt :: Integer -> [Char] -> Integer
+fastHeightAt idx jets =
+  let states = simulate jets
+      stateCycle@Cycle {..} = findCycle states
+      (offset, repeats) = calcOffsetRepeat stateCycle
+   in heightAt offset states + repeats * cycleHeight
+  where
+    calcOffsetRepeat :: Cycle -> (Int, Integer)
+    calcOffsetRepeat Cycle {..} =
+      let cycleLength = repeatIdx - startIdx
+          totalOffset = startIdx + (idx - startIdx) `mod` cycleLength
+          repeats = (idx - totalOffset) `div` cycleLength
+       in (fromInteger totalOffset, repeats)
+
+    heightAt :: Int -> [CachedFormation] -> Integer
+    heightAt offset = toInteger . fullHeight . (!! offset)
+
+part1 :: [Char] -> Integer
+part1 = fastHeightAt 2_022
+
+part2 :: [Char] -> Integer
+part2 = fastHeightAt 1_000_000_000_000
+
+day :: Day
+day = StringDay $ \jets ->
+  Right
+    ( definitive $ part1 jets,
+      definitive $ part2 jets
+    )

src/Lib.hs

@@ -28,6 +28,7 @@ import Days.D13 qualified as D13
 import Days.D14 qualified as D14
 import Days.D15 qualified as D15
 import Days.D16 qualified as D16
+import Days.D17 qualified as D17
 
 import Data.ByteString.Char8 qualified as BS
 import Data.Text.IO qualified as T
@@ -56,4 +57,5 @@ days =
     , [D14.day]
     , [D15.day]
     , [D16.day]
+    , [D17.day]
     ]