Advent of Code 2023 day 23

    Day 23 was about finding the longest paths in a graph, which is an NP-complete problem. Luckily, this problem is fairly small, so I can solve it in a sensible time.

    Representation

    I decided on a "sparse" representation of the map, which made part 2 a little bit more convenient.

    A Position is the now-typical V2. The Slide is a new type. The forest grid is a Set of Position; the Slides is a Map from Position to Slide.

    data Slide = SlideLeft | SlideRight | SlideUp | SlideDown
      deriving (Show, Eq)
    
    type Position = V2 Int -- r, c
    
    _r, _c :: Lens' (V2 Int) Int
    _r = _x
    _c = _y
    
    type Grid = S.Set Position
    type Slides = M.Map Position Slide

    Reading the input is working through character-by-character. The only wrinkle is that I put a "cap" on the start and end positions to prevent the search wandering into the infinite space outside the map.

    mkGrid :: String -> (Grid, Slides, Position, Position)
    mkGrid text = ((S.union forest caps), slides, start, end)
      where rows = lines text
            maxR = length rows - 1
            maxC = (length $ head rows) - 1
            forest = S.fromList [ V2 r c | r <- [0..maxR], c <- [0..maxC]
                                , rows !! r !! c == '#'
                                ]
            slides = M.fromList [ (V2 r c, readSlide (rows !! r !! c))
                                | r <- [0..maxR], c <- [0..maxC]
                                , elem (rows !! r !! c) ("<>^v" :: String)
                                ]
            start = head $ [ V2 0 c | c <- [0..maxC]
                           , rows !! 0 !! c == '.'
                           ]
            end = head $ [ V2 maxR c | c <- [0..maxC]
                         , rows !! maxR !! c == '.'
                         ]
            caps = S.fromList [start ^+^ (V2 -1 0), end ^+^ (V2 1 0)]
    
    readSlide :: Char -> Slide
    readSlide '<' = SlideLeft
    readSlide '>' = SlideRight
    readSlide '^' = SlideUp
    readSlide 'v' = SlideDown

    Compression

    Part 1 is simple enough to solve with a direct graph search. Part 2 is too large for that. However, the map is organised as mostly long winding trails with only a few junctions. That means the overall problem reduces to one of picking a direction at each junction, and just looking up the distances from junction to junction.

    That means I need to find those distances and how to look them up.

    A CompressedMap is a Map from a Position (a junction) to a list of directly-connected junctions. Those paths are represented by aCompressedPath that stores the neighbouring junction and the distance to it.

    data CompressedPath = CPath { _nextPos :: Position, _pathLen :: Int }
      deriving (Show, Eq)
    makeLenses ''CompressedPath
    
    type CompressedMap = M.Map Position [CompressedPath]

    Given a forest, the slides, and a position, I can work out the reachable adjacent positions.

    adjacents :: Position -> Slides -> Grid -> [Position]
    adjacents here slides forest = filter (`S.notMember` forest) $ fmap (here ^+^) deltas
      where deltas = case M.lookup here slides of
                      Nothing ->  [ V2 0 1, V2 1 0, V2 0 (-1), V2 (-1) 0 ]
                      Just SlideLeft -> [ V2 0 (-1) ]
                      Just SlideRight -> [ V2 0 1 ]
                      Just SlideUp -> [ V2 (-1) 0 ]
                      Just SlideDown -> [ V2 1 0 ]

    The junctions, the "interesting points", are those with more than two adjacent positions (and the start and end). I use those to initially populate the compressed map.

    interestingPoints :: Slides -> Grid -> Position -> Position -> CompressedMap
    interestingPoints slides forest start end = M.fromList [(p, []) | p <- pointsSE]
      where Just minR = minimumOf (folded . _r) forest
            Just maxR = maximumOf (folded . _r) forest
            Just minC = minimumOf (folded . _c) forest
            Just maxC = maximumOf (folded . _c) forest
            points = [ V2 r c | r <- [(minR + 2)..(maxR - 2)]
                     , c <- [(minC + 1)..(maxC - 1)]
                     , (V2 r c) `S.notMember` forest
                     , (length $ adjacents (V2 r c) slides forest) > 2
                     ]
            pointsSE = start : end : points

    I then do a breadth-first search from each interesting point, stopping when the path reaches another interesting point. I store the results in the compressed map, so long as it's not a loop back to the original point.

    searchStep :: Slides -> Grid -> [Position] -> [[Position]]
    searchStep _ _ [] = []
    searchStep slides forest path@(here:rest) = fmap (:path) valids
      where nexts = adjacents here slides forest
            valids = filter (`notElem` rest) nexts
    
    search :: Slides -> Grid -> [Position] -> CompressedMap -> [[Position]] -> CompressedMap
    search _ _ _ foundPaths [] = foundPaths
    search slides forest goals foundPaths (current:agenda)
      | head current `elem` goals = search slides forest goals foundPaths' agenda
      | otherwise = search slides forest goals foundPaths (agenda ++ extendeds)
      where extendeds = searchStep slides forest current
            origin = last current
            foundPaths' = if origin == head current then foundPaths
                            else M.adjust (cp :) origin foundPaths
            cp = CPath (head current) (length current - 1)

    Solution

    Given the compressed map, finding the solution is much the same. This time, I use a depth-first search, recording all complete paths from start to end.

    searchCompressed :: CompressedMap -> Position -> [[Position]] -> [[Position]] -> [[Position]]
    searchCompressed _ _ found [] = found
    searchCompressed map goal found (current:agenda) 
      | head current == goal = searchCompressed map goal (current:found) agenda
      | otherwise = searchCompressed map goal found (nextPositions ++ agenda)
      where neighbours0 = map M.! (head current)
            neighbours = neighbours0 ^.. folded . filtered ((`notElem` current) . _nextPos)
            nextPositions = fmap ((: current) . _nextPos) neighbours

    Once I have a path, I find its length by adding up the lengths of all the path segments.

    pathLength :: CompressedMap -> [Position] -> Int
    pathLength map ps = sum $ zipWith (stepLength map) ps $ tail ps
    
    stepLength :: CompressedMap -> Position -> Position -> Int
    stepLength map here there = 
      head $ (map M.! there) ^.. folded . filteredBy (nextPos . only here) . pathLen

    Part 1 and part 2 only differ in how the compressed map is made: part 1 includes the slides, part 2 ignores them.

    part1, part2 :: Slides -> Grid -> Position -> Position -> Int
    part1 slides forest start end = maximum $ fmap (pathLength cMap) paths
      where cMap = compress slides forest start end
            paths = searchCompressed cMap end [] [[start]]
    part2 _ forest start end = maximum $ fmap (pathLength cMap) paths
      where cMap = compress M.empty forest start end
            paths = searchCompressed cMap end [] [[start]]

    Code

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

    Neil Smith

    Read more posts by this author.