Advent of Code 2022 day 17

Day 17 was another problem where the approach to part 2 had to be very different from part 1. Part 1 was a simulation of the rocks dropping. Part 2 was about finding repeated states in that process, and using that to avoid doing excessive computation.

Part 1

Representation

The simulation relies a lot on Haskell's laziness. I generate infinite lists of gas jets, rocks, and simulated states, then pick out just the elements of these that I need. I greatly simplifies the code, as I don't need to keep caching particular states of the simulation.

The core of the simulation is the SimulationState, that represents the current simulation: the chamber containing dropped rocks, the infinite list of upcoming gas jets, the infinite list of upcoming rocks, and the number of rocks that have been dropped so far. There's also a custom Show instance, to show the state without asking Haskell to print the entire infinite lists!

type Position = V2 Int -- x, y; y increasing upwards
type Chamber = S.Set Position
type Rock = S.Set Position

data SimulationState = SimulationState
  { _chamber :: Chamber
  , _jets :: [Position]
  , _rocks :: [Rock]
  , _droppedCount :: Int
  } deriving (Eq, Ord)
makeLenses ''SimulationState

instance Show SimulationState where
  show sState = "SimState { _chamber = " 
                ++ (show $ sState ^. chamber) 
                ++ ", _jets = " 
                ++ (show (take 5 (sState ^. jets))) 
                ++ ", _rocks = " 
                ++ (show (take 5 (sState ^. rocks))) 
                ++ ", _droppedCount = " 
                ++ (show (sState ^. droppedCount)) 
                ++ " }"

Making the list of jets and rocks is simple enough, using cycle to generate the infinite lists.

mkJets :: String -> [Position]
mkJets = fmap mkJet
  where mkJet '<' = V2 -1 0
        mkJet '>' = V2 1 0
        mkJet _ = error "Illegal jet character"

mkRocks :: [Rock]
mkRocks = cycle $ fmap mkRock rockPics

mkRock :: String -> Rock
mkRock rockPic = S.fromList 
    [ V2 x y 
    | x <- [0..((length (rockLines!!0)) - 1)]
    , y <- [0..((length rockLines) - 1)]
    , (rockLines!!y)!!x == '#'
    ]
  where rockLines = reverse $ lines rockPic

rockPics :: [String]
rockPics = ["####", ".#.\n###\n.#.", "..#\n..#\n###", "#\n#\n#\n#", "##\n##"]

Finally, I have a utility function for drawing pictures of hte chamber, which was useful for debugging the simulation.

showChamber :: Chamber -> String
showChamber chamber = unlines 
  [ [showCell x y | x <- [0..6]]
  | y <- reverse [1..yMax]
  ] ++ "-------"
  where yMax = fromMaybe 0 $ maximumOf (folded . _y) chamber
        showCell x y 
          | (V2 x y) `S.member` chamber = '#'
          | otherwise = '.'

Simulation

Each sub-step of the simulation, pushing and falling, is a function. push checks that the pushed rock is still inside the chamber and doesn't overlap any static rocks. fall drops the rock if possible, and returns Nothing if the rock should come to rest.

push chamber rock direction 
  | disjoint && inLeft && inRight = pushedRock
  | otherwise = rock
  where pushedRock = S.map (^+^ direction) rock
        disjoint = S.null $ S.intersection pushedRock chamber
        inLeft = (fromJust $ minimumOf (folded . _x) pushedRock) >= 0
        inRight = (fromJust $ maximumOf (folded . _x) pushedRock) <= 6

fall chamber rock 
  | disjoint && aboveFloor = Just droppedRock
  | otherwise = Nothing
  where droppedRock = S.map (^+^ (V2 0 -1)) rock
        disjoint = S.null $ S.intersection droppedRock chamber
        aboveFloor = (fromJust $ minimumOf (folded . _y) droppedRock) > 0

dropRock combines these two stages, updating the simulation state as it goes.

dropRock simState rock 
  | rock2 == Nothing = simState & chamber %~ (S.union rock1) 
                                & jets %~ tail 
  | otherwise = dropRock (simState & jets %~ tail) $ fromJust rock2 
  where rock1 = push (simState ^. chamber) rock (head (simState ^. jets))
        rock2 = fall (simState ^. chamber) rock1

Finally, dropFromTop simulates the entire fall of a rock, from when it appears to when it comes to rest.

dropFromTop simState = (dropRock simState (initialPlace simState)) 
                          & rocks %~ tail 
                          & droppedCount %~ (+ 1)

initialPlace simState = S.map (^+^ (V2 2 startHeight)) rock
  where startHeight = 4 + (fromMaybe 0 $ maximumOf (folded . _y) (simState ^. chamber))
        rock = head $ simState ^. rocks

The simulate function creates the initial simulation state and uses iterate to find the desired state, and rocksHeight makes heavy use of lenses to find the height of a pile of rocks.

part1 oneJetCycle = rocksHeight $ simulate mkRocks (cycle oneJetCycle) 2022

rocksHeight state = fromMaybe -1 $ maximumOf (folded . _y) (state ^. chamber)

simulate rocks jets n = (!!n) $ iterate dropFromTop initState
  where initState = SimulationState { _chamber = S.empty, _jets = jets, _rocks = rocks, _droppedCount = 0}

Part 2

Obviously, simulating 10¹² rocks is infeasible, so I need another approach. The good news is I don't need to know the detail of all the dropped rocks to know where the next rock will end up. All that's needed is the shape of the top of the pile, alongside where I am in the cycle of jets and rocks. As the chamber isn't very wide, that arrangement will reappear fairly soon.

First, I need to capture the salient parts of the simulation into a "simulation profile", using the heights in each column relative to the highest column, along with the next bunch of jets and the next rock.

simulationProfile jetLength state = 
  ( surfaceProfile state
  , take jetLength $ state ^. jets
  , head $ state ^. rocks
  )

surfaceProfile state = S.fromList $ map (^-^ (V2 0 peak)) rawProfile
  where ch = state ^. chamber
        rawProfile = [V2 i (fromMaybe -1 $ maximumOf (folded . filteredBy (_x . only i) . _y) ch) | i <- [0..6] ]
        peak = fromJust $ maximumOf (folded . _y) rawProfile

I use Floyd's "tortoise and hare" algorithm for finding those repeated states, and the cycle length. The first stage is to find a repeated state, by running two simulations in parallel. I check on the second after every two simulation steps. These two simulations will be the same profile after some multiple of the repeating-cycle length.

Again, laziness is useful as I can just declare two infinite simulations and throw away the states that don't match.

findEarliestRepeat jetLength simState = head $ dropWhile (uncurry (differentProfiles jetLength)) pairs
  where tortoises = drop 1 $ iterate dropFromTop simState
        hares = drop 1 $ iterate (dropFromTop . dropFromTop) simState
        pairs = zip tortoises hares

differentProfiles jetLength t h = (simulationProfile jetLength t) /= (simulationProfile jetLength h)

Once I have the state where the cycle starts, I can find the cycle length by doing another simulation from there.

findCycleRepeat jetLength cycleStart = head $ dropWhile (differentProfiles jetLength cycleStart) hares
  where hares = drop 1 $ iterate dropFromTop cycleStart

Given these two simulation states, I can find the final height with a bit of arithmetic.

For the example given in the problem, the cycle starts after 35 rocks have dropped (for a height of 60), and the same profile is reached after 70 rocks have dropped (with a height of 113). That means that, after 35 rocks, each additional 70 - 35 = 35 rocks increases the height of the pile by 113 - 60 = 53.

I can make a pile of 1,000,000,000,000 rocks by dropping the initial 35, then 2,8571,428,570 repeats of 35 rocks, then a final 15 rocks. Those repeated cycles add 1,514,285,714,210 to the height of the pile.

If I drop the initial 35 rocks, then the final 15, that gives me a height of 78. If I add the 1,514,285,714,210 from the repeated groups, that gives a final pile height of 1,514,285,714,288. And that's the answer!

part2 oneJetCycle = calculatedHeight
  where initState = SimulationState 
                      { _chamber = S.empty
                      , _jets = (cycle oneJetCycle)
                      , _rocks = mkRocks
                      , _droppedCount = 0
                      }
        (cycleStartState, _) = findEarliestRepeat (length oneJetCycle) initState
        cycleRepeatState = findCycleRepeat (length oneJetCycle) cycleStartState
        cycleStart = cycleStartState ^. droppedCount
        cycleLength = (cycleRepeatState ^. droppedCount) - cycleStart
        startHeight = rocksHeight cycleStartState
        differenceHeight = (rocksHeight cycleRepeatState) - startHeight
        afterStart = 1000000000000 - cycleStart
        (numCycles, remainingDrops) = afterStart `divMod` cycleLength
        finalState = (!!remainingDrops) $ iterate dropFromTop cycleStartState
        finalHeight = rocksHeight finalState
        calculatedHeight = finalHeight + (differenceHeight * numCycles)

Code

You can get the code from my locally-hosted Git repo, or from Gitlab.