Advent of Code 2023 day 14

    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.

    Neil Smith

    Read more posts by this author.