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.