Advent of Code 2024 day 6

Day 6 was fairly simple to code up, but the wrinkle came in optimising it to run fast (the "completes in at most 15 seconds on ten-year-old hardware" condition).

Part 1

I started of by not doing anything fancy. I read the map into an Array of Bool, using the same approach as I did in day 4. I could have used a spare representation of a Set of obstacles, but the map wasn't that big and an Array has the advantage of having the bounds easily-accessible. The Guard is a record of position and direction, and I reused some direction pattern directives to keep things easy (not that I used them).

type Position = V2 Int -- r, c
type Grid = Array Position Bool

pattern U, D, L, R :: Position
pattern U = V2 (-1) 0
pattern D = V2 1 0
pattern L = V2 0 (-1)
pattern R = V2 0 1

data Guard = Guard { pos :: Position, dir :: Position }
  deriving (Show, Eq)

turnRight :: Position -> Position
turnRight U = R
turnRight R = D
turnRight D = L
turnRight L = U

I did think about using a reader-writer-state monad to do the simulation, but then I realised that was overkill. I'm updating a state and capturing a list of changes to that state; that's the shape of an unfold.

A walk is an unfolding of steps; a step is one action by the guard. There's a bit of fiddling to ensure I keep both the first and last position in the trail.

walk :: Grid -> Guard -> [Position]
walk grid guard = unfoldr (step grid) guard

step :: Grid -> Guard -> Maybe (Position, Guard)
step grid guard 
  | not (inRange (bounds grid) guard.pos) = Nothing
  | not (inRange (bounds grid) ahead) = Just (guard.pos, guard { pos = ahead })
  | grid ! ahead = Just (guard.pos, guard { dir = turnRight $ guard.dir })
  | otherwise = Just (guard.pos, guard { pos = ahead })
  where ahead = guard.pos ^+^ guard.dir

And that solves part 1, after deduplicating the places where the guard crosses their own path.

part1 grid guard = length $ nub $ walk grid guard

Part 2

This is looking for loops, and seeing which new obstacles would produce a loop. Conceptually, it's easy. Place a new obstacle in every position, see if it generates a loop. I detect a loop if the guard returns to a state (position and direction) they were in previously; it's not a loop if the guard walks out of the map.

part2 grid guard = length $ filter (isLoop guard []) modifiedGrids
  where modifiedGrids = [ grid // [ (new, True) ] 
                        | range (bounds grid)
                        , new /= guard.pos
                        ]

isLoop :: Guard -> [Guard] -> Grid -> Bool
isLoop guard trail grid
  | isNothing stepped = False
  | guard' `elem` trail = True
  | otherwise = isLoop guard' (guard:trail) grid
  where stepped = step grid guard
        (_, guard') = fromJust stepped                

That works, but takes a very long time. Time for some optimisation.

Optimising

My first improvement happened almost immediately. After waiting for a few minutes, I realised I didn't need to test every position for the placement of a new obstacle, just the positions that the guard would meet; that meant just the positions on the guard's original route. That dropped number of candidate positions from 17,000 to about 5,000, but still took about 2m 45s to run.

part2 grid guard = length $ filter (isLoop guard []) modifiedGrids
  where modifiedGrids = [ grid // [ (new, True) ] 
                        | new <- news
                        , new /= guard.pos
                        ]
        news = nub $ walk grid guard

This is a very parallelisable problem, so I tried that next. I imported the parallel library and did the loop checking in a parallel map. I tried a few different parallelisation strategies, but they were all much of a sameness. That brought the time down to about 17–20 seconds.

part2 grid guard = length $ filter id loopResults
  where modifiedGrids = [ grid // [ (new, True) ] 
                        | new <- news
                        , new /= guard.pos
                        ]
        loopResults = parMap rpar (isLoop guard []) modifiedGrids
        news = nub $ walk grid guard

That was good enough for me.

But then I looked on the Reddit solution thread, and saw a lot of people getting better performance by doing less work in isLoop. The idea is that you only record and check positions when the guard turns. That makes the loop test much faster, as the cache of locations is that much smaller.

isLoop :: Guard -> [Guard] -> Grid -> Bool
isLoop guard trail grid
  | isNothing stepped = False
  | hasTurned && guard `elem` trail = True
  | hasTurned = isLoop guard' (guard:trail) grid
  | otherwise = isLoop guard' trail grid
  where stepped = step grid guard
        (_, guard') = fromJust stepped
        hasTurned = guard.dir /= guard'.dir

That makes the single-threaded version run in about 0.9 seconds and the parallel version in about 0.3 seconds.

Code

You can get the code from my locally-hosted Git repo, or from Codeberg. The single-threaded version is in Main.hs, the parallel version is in MainPar.hs.