The theme of Day 14 was about repeating things a few times until they stopped. Which is a bit gnomic, but hopefully will be come clear.

I read the data directly from the data, using a new type to store the types of element. The thing to note is that the Grid type is use to represent the map as a set of columns: the first element of a grid is the left-most column, with the top of that column as the first element. (I also built showGrid for use in debugging and testing.)

data Element = Empty | Cube | Round deriving (Show, Eq, Ord)
type Grid = [[Element]]

grid = transpose $ fmap (fmap readElem) $ lines text

readElem :: Char -> Element
readElem '.' = Empty
readElem '#' = Cube
readElem 'O' = Round

showGrid :: Grid -> String
showGrid grid = unlines $ fmap (fmap showElem) $ transpose grid
  where showElem Empty = '.'
        showElem Cube = '#'
        showElem Round = 'O'

Part 1

With a column-centric representation, I can move all the round boulders up by moving each column independently. Rolling each column is a fold, combining three sections: the column already processed, the current gap, and the boulder that may roll into it. rollStep handles the moving logic, and roll sets up the sections.

rollGrid :: Grid -> Grid
rollGrid = fmap roll

roll :: [Element] -> [Element]
roll [] = []
roll (l:ls) = rs ++ [r]
  where (rs, r) = foldl' rollStep ([], l) ls

rollStep :: ([Element], Element) -> Element -> ([Element], Element)
rollStep (handled, Empty) Round = (handled ++ [Round], Empty)
rollStep (handled, target) source = (handled ++ [target], source)

But rollGrid will move each Round boulder at most once. rollToCompletion keeps repeating rollGrid (using iterate) until there's no change in the grid.

rollToCompletion :: Grid -> Grid
rollToCompletion grid = fst $ head $ 
							dropWhile (uncurry (/=)) $ 
                            zip states $ tail states
  where states = iterate rollGrid grid

All that's left is scoring a grid and we're done.

scoreGrid :: Grid -> Int
scoreGrid grid = sum $ fmap scoreRow indexedGrid
  where indexedGrid = zip [1..] $ reverse $ transpose grid
        scoreRow (i, r) = i * (length $ filter (== Round) r)

Part 2

This has two sections. One is rotating the grid to do the cycle; the other is dealing with the ludicrous number of cycles needed.

Rotating

For rotation, I looked at the Cayley table of the D4 group (the symmetry group of a square) and saw that a rotation a quarter-turn clockwise is flipping the top and bottom of the grid, then flipping across the top-left-to-bottom-right diagonal.

rotate1 :: Grid -> Grid
rotate1 = transpose . fmap reverse

One step of a cycle is rolling all boulders then rotating the grid; a full cycle is doing that four times. I used the endofuctor monoid Endo to use stimes, making clear that a rollCycle is four of the steps.

rollCycle :: Grid -> Grid
rollCycle = appEndo (stimes 4 (Endo rotate1 <> Endo rollToCompletion))

Repeating

My intuition for dealing with the number of cycles is that the arrangement of boulders would repeat after a certain number of cycles. I could use that to quickly find what the pattern would be after one billion cycles.

Finding a cycle, and using it, requires detecting duplicate grids, and remembering, for each grid, how long until it first appeared. That's wrapped up in a Map from Grid to Int (the cycle number).

To find the repeats, I use iterate to generate an infinite list of cycled grids, building up the cache as I go. (The state being tracked through the iterate is the current state, the cached states, and the current cycle number.) I throw away the first few cycles (with dropWhile), on condition that the current grid isn't in the cache.

type Cache = M.Map Grid Int

findRepeat :: Grid -> (Grid, Cache, Int)
findRepeat grid = head $ dropWhile test $ iterate go (grid, M.empty, 0)
  where test (g, c, _) = g `M.notMember` c
        go (g, c, i) = (rollCycle g, M.insert g i c, (i + 1))

What comes back from findRepeat is the information I need to solve the problem.

grid' is the first repeated state, and repeatStart is when I first saw that state. that means grid' occurs after repeatStart cycles, and repeatStart + repeatLen, and repeatStart + 2 × repeatLen cycles, and so on. In other words, I can chop out as many chunks of repeatLen from the limit as I want and things will be the same. The calculation below does all that.

Once I know which element in the cache corresponds to the grid after a billion cycles, I can pull it out and score it.

part2 grid = scoreGrid finalGrid
  where (grid', cache, repeatEnd) = findRepeat grid
        repeatStart = cache M.! grid'
        repeatLen = repeatEnd - repeatStart
        finalIndex = ((1e9 - repeatStart) `mod` repeatLen) + repeatStart
        (finalGrid, _) = M.findMin $ M.filter (== finalIndex) cache

Of course, this didn't work first time, as I forgot to add repeatStart in the calculation for finalIndex then spent ages hunting down an off-by-one error that didn't exist!

Disappointingly, this takes about 1½ minutes to find a solution. I've not investigated, but it's probably down to the structure of the Grid taking time to process. Perhaps I'll revisit this and use an Array instead.

Code

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