From 167ce73a4cca0809bf89d2560d5be9bd09ef4844 Mon Sep 17 00:00:00 2001 From: Christian Date: Tue, 24 Oct 2023 09:14:43 +0200 Subject: [PATCH] Day 17 --- Y2022.cabal | 2 + app/Main.hs | 1 + bench/Bench.hs | 1 + data/17.in | 1 + src/Days/D17.hs | 246 ++++++++++++++++++++++++++++++++++++++++++++++++ src/Lib.hs | 2 + 6 files changed, 253 insertions(+) create mode 100644 data/17.in create mode 100644 src/Days/D17.hs diff --git a/Y2022.cabal b/Y2022.cabal index f7fd153..904be80 100644 --- a/Y2022.cabal +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index 94f1cf5..7c40a22 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,6 +24,7 @@ paths = , "./data/14.in" , "./data/15.in" , "./data/16.in" + , "./data/17.in" ] solutions :: [(Int, Day, FilePath)] diff --git a/bench/Bench.hs b/bench/Bench.hs index d365a04..0a589cd 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -23,6 +23,7 @@ paths = , "./data/14.in" , "./data/15.in" , "./data/16.in" + , "./data/17.in" ] solutions :: [(Integer, [Day], FilePath)] diff --git a/data/17.in b/data/17.in new file mode 100644 index 0000000..97a1aa1 --- /dev/null +++ b/data/17.in @@ -0,0 +1 @@ +>>><<><>><<<>><>>><<<>>><<<><<<>><>><<>> diff --git a/src/Days/D17.hs b/src/Days/D17.hs new file mode 100644 index 0000000..a3633e9 --- /dev/null +++ b/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 + ) diff --git a/src/Lib.hs b/src/Lib.hs index 278f3e3..0b33bda 100644 --- a/src/Lib.hs +++ b/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] ]