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 SlideReading 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' = SlideDownCompression
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 : pointsI 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) neighboursOnce 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) . pathLenPart 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.