There are plenty of clever algorithms to solve the day 25 puzzle, but I decided to forego those and use a probabilistic brute-force approach.

The graph has two highly-connected components with the three edges connecting them. If I pick two nodes at random, the shortest path between them may stay within one component or may cross from one to the other. If those two components are about equal in size (they're both about 700 nodes in my input), then about half those paths will moves between components. If it goes between components, the path will include one of the cut-set edges. That means the cut-set edges will appear in many more paths than the other edges.

That's the idea behind my solution. The steps I took to solve it are:

• Generate a few hundred random pairs of nodes and find the paths between them.
• Convert the sequences of nodes to the edges used (with getEdges). Count how many times each edge appears in all the paths put together. (This uses a Multiset to handle the counting.)
• The three most common edges are the cut set.
• Remove those edges from the graph
• Find the sizes of the two now-disconnected components.

Or, in code, it looks like this:

part1 :: Graph -> Int
part1 graph = (S.size componentA) * (S.size componentB)
  where (ss, gs) = splitAt 200 $ randomNodes graph 400
        paths = fmap toList $ catMaybes $ fmap (bfsPair graph) $ zip ss gs
        pathCounts = MS.fromList $ concatMap getEdges paths
        populars = fmap snd $ take 3 $ reverse $ sort $ fmap swap $ MS.toOccurList pathCounts 
        separatedGraph = foldl' removeEdge graph populars
        (a, b) = head populars
        componentA = componentOf separatedGraph (S.singleton a) S.empty
        componentB = componentOf separatedGraph (S.singleton b) S.empty

getEdges :: [String] -> [(String, String)]
getEdges xs = zipWith go xs (tail xs)
  where go a b 
          | a < b = (a, b)
          | otherwise = (b, a)   

For my inputs, the three most common edges appeared 42, 27, and 25 times, with the rest occurring less than 20 times.

I'll now cover each of these stages in turn.

Reading and completing the graph, removing edges

The graph is just a Map from name (a String) to a list of names. Reading it is simple parsing.

type Graph = M.Map String [String]

graphP = M.fromList <$> nodeP `sepBy` endOfLine
nodeP = (,) <$> (nameP <* ": ") <*> (nameP `sepBy` " ")
nameP = many1 letter

This is a directed graph, so I need to add the reverse links to make it the undirected graph that's in the puzzle. It's a fold over a fold. Essentially, for each here node on the left of a rule, and for each there node on the right of a rule, I add the connection there → here.

reverseGraph :: Graph -> Graph
reverseGraph graph = M.foldlWithKey' reverseNode graph graph

reverseNode :: Graph -> String -> [String] -> Graph
reverseNode graph here theres = foldl' (addReversed here) graph theres

addReversed :: String -> Graph -> String -> Graph
addReversed here graph there = M.insertWith (++) there [here] graph

While I'm here, we'll also need to remove some edges from the graph. For the edge connecting a and b, delete b from the connections of a and delete a from the connections of b.

removeEdge :: Graph -> (String, String) -> Graph
removeEdge graph (a, b) = M.adjust (delete a) b $ M.adjust (delete b) a graph

Finding random nodes

I don't often use random numbers in Haskell. This is essentially cribbed from the example in the System.Random documentation. Note that it always uses the same seed for the random number generation.

randomNodes :: Graph -> Int -> [String]
randomNodes graph n = fmap (\i -> fst $ M.elemAt i graph) indices
  where range = (0, M.size graph - 1)
        pureGen = mkStdGen 137
        indices = take n $ unfoldr (Just . uniformR range) pureGen

Finding routes

I find routes with breadth-first search, using an agenda of paths and a closed set of already-processed nodes. The closed set is a Set and the agenda is a Sequence of paths, with each path being a Sequence of node labels. bfs does the search; bfsPair sets it up given a pair of node labels.

bfsPair :: Graph -> (String, String) -> Maybe (Seq String)
bfsPair graph (start, goal) = bfs graph (Q.singleton (Q.singleton start)) goal S.empty

bfs :: Graph -> Seq (Seq String) -> String -> S.Set String -> Maybe (Seq String)
bfs _ Q.Empty _ _ = Nothing
bfs graph (current :<| agenda) goal closed
  | here == goal = Just current
  | here `S.member` closed = bfs graph agenda goal closed
  | otherwise = bfs graph (agenda >< nexts) goal (S.insert here closed)
  where (_ :|> here) = current
        nexts = Q.fromList $ fmap (current :|>) $ graph ! here

Finding components

This is very similar to breadth-first search. There is a Set of found nodes and a Set of nodes on the boundary of the search. I pick an arbitrary node on the boundary, add it to found, then add its neighbours to the boundary (but not the already-found ones).

componentOf :: Graph -> S.Set String -> S.Set String -> S.Set String
componentOf graph boundary0 found
  | S.null boundary0 = found
  | otherwise = componentOf graph boundary2 found'
  where (here, boundary1) = S.deleteFindMin boundary0
        found' = S.insert here found
        boundary2 = S.union boundary1 $ (S.fromList $ graph ! here) \\ found'

Imports

As an aside, this seemingly-simple bit of code requires a huge number of imports.

import AoC
import Data.Text (Text)
import qualified Data.Text.IO as TIO
import Data.Attoparsec.Text hiding (take)
import Data.List (foldl', unfoldr, sort, delete)
import qualified Data.Map as M
import Data.Map ((!))
import qualified Data.Set as S
import Data.Set ((\\))
import qualified Data.Sequence as Q
import Data.Sequence ( (><), Seq(..) )
import Data.Foldable (toList)
import Data.Maybe (catMaybes)
import System.Random
import qualified Data.MultiSet as MS
import Data.Tuple (swap)

Finish

And that's Advent of Code done for another year! I'll come back to this with a review of what I used, what I learnt, and perhaps what could be optimised. In the meantime, I'll enjoy my 450 total stars.

Code

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