For day 11, I started off with hand-built solution that was overly-defensive. Then I was reminded of the Data.Graph library in the containers module, and rebuilt the solution much more simply using that. However, the approach in both parts is the same.

We're given a directed graph and have to count the number of distinct paths to get from one specified vertex to another. For part 1, it's from one vertex to one other. For part 2, each path has to include two other specified vertices.

First, I'll cover my hand-built solution, as I think it shows off how to be a bit defensive with these problems. After that, I'll show the alternate implementation using the Data.Graph library.

Parsing and representing a graph

The input file gives the graph in the form of adjacency lists, where each vertex stores its (directed) neighbours. That suggests I represent it as a Map from a vertex to a list of neighbouring vertices. The structure of the parser follows, complicated only by the need to define a space character as a separator.

type Graph = M.Map String [String]

graphP = M.unionsWith (++) <$> linkP `sepBy` endOfLine
linkP = M.singleton <$> tokenP <* ": " <*> (tokenP `sepBy` hSpace)
tokenP = many1 letter
hSpace = char ' '

Graph properties

Solving the rest of the problem needs a bit of thinking about graphs and their properties. Understanding the features of the problem leads fairly naturally to a solution.

The first thing is that the number of distinct routes from A to B is only defined if there are no (directed) cycles from A to B. If there is a cycle, there are an infinite number of different routes, most of them differing only by the number of times you go around the cycle. That means, for this problem, there are no cycles between the given nodes. However, there could well be cycles elsewhere in the full graph.

That suggests I should find the subgraph that just concerns the possible routes between the two given nodes.

The second thing is that I don't need to find all the routes, just count how many there are. I can do a dynamic programming type approach here by annotating each vertex with the number of routes to get to that vertex. If I know the number of routes into each predecessor of a vertex, I can find the number of routes to that vertex by summing the number of routes to all its predecessors. For instance, in the sample graph below, I can find the number of ways of getting from you to ddd if I know the number of ways to get from you to each of ddd's predecessors (i.e. bbb and ccc).

That suggests I need a way of tracking the number of distinct routes to each vertex in the graph, and easily finding the predecessors of each vertex.

The third thing is that the above calculation of routes relies on building them up in order, from the given vertex until the end of the graph. That order is the topological sort order of the vertices in the graph.

That suggests I need to find the topological sort of a graph.

Let's take these one at a time.

Finding the relevant subgraph

The possible routes from A to be can only include the vertices that are reachable from A, and the vertices from which B is reachable. Finding the vertices reachable from A is an exhaustive search from A (including detecting loops). Finding the vertices from which B is reachable is the same as inverting the graph (reversing the direction of all the edges) and finding the vertices reachable from B. The subgraph will be the graph that contains only the vertices that are in both sets.

To find reachable vertices (also called the successors, or the descendants), I perform a breadth-first search, maintaining a list of reachable vertices and an agenda of vertices to process. I also included a set of terminal vertices that stop the search beyond them, but that ended up being not very useful.

descendants :: Graph -> [String] -> [String] -> [String] -> [String]
descendants _ _ acc [] = acc
descendants g terminals acc (v:vs)   
  | v `elem` acc = descendants g terminals acc vs 
  | v `elem` terminals = descendants g terminals (v:acc) vs 
  | otherwise = descendants g terminals (v:acc) (vs ++ (M.findWithDefault [] v g)) 

Inverting a graph involves inverting each edge (using a fold), and combining them with M.unionWith (++) to combine the reversed edges.

invertGraph :: Graph -> Graph
invertGraph g = M.foldlWithKey' invertLink M.empty g

invertLink :: Graph -> String -> [String] -> Graph
invertLink acc parent children = M.unionWith (++) acc inverted
  where inverted = M.fromList [(child, [parent]) | child <- children]

subGraphBetween finds the two sets of vertices, combines them, then extracts out the relevant subgraph.

subGraphBetween :: Graph -> Graph -> String -> String -> Graph
subGraphBetween graph invGraph here there = subGraphUsing commons graph
  where descs = descendants graph [there] [] [here]
        ancs = descendants invGraph [here] [] [there]
        commons = descs `intersect` ancs

subGraphUsing :: [String] -> Graph -> Graph
subGraphUsing vs g = g''
  where g' = M.filterWithKey (\k _ -> k `elem` vs) g
        g'' = M.map (`intersect` vs) g'

Topological sorting

This is a standard problem with several standard algorithms. I used Kahn's algorithm, translating it directly into Haskell.

kahnSort :: Graph -> VertexCount -> [String] -> [String] -> [String]
-- kahnSort graph invGraph inDegrees queue ordering
kahnSort _ _ [] ordering = ordering
kahnSort graph inDegrees (v:vs) ordering 
  | M.member v graph = kahnSort graph inDegrees'' (nub $ vs ++ newZeroes) (v:ordering)
  | otherwise = kahnSort graph inDegrees vs (v:ordering)
  where neighbours = graph ! v
        inDegrees' = foldl' reduceDegrees inDegrees neighbours
        inDegrees'' = M.filter (/= 0) inDegrees' 
        newZeroes = M.keys $ M.filter (== 0) inDegrees'

reduceDegrees :: VertexCount -> String -> VertexCount
reduceDegrees g n = 
  case M.lookup n g of
    Just k -> M.insert n (max 0 (k - 1)) g
    Nothing -> g

initialInDegrees :: Graph -> Graph -> VertexCount
initialInDegrees graph invGraph = M.union nonZeroes zeroes
  where nonZeroes = M.map length invGraph
        zeroes = M.map (const 0) graph    

This doesn't terminate if there are cycles in the graph, but if I only sort the subGraphBetween, that should be fine.

Counting routes

This uses the list of vertices in topological-sort order, seeding the set of counts as 1 for the root node. The work is done in addVertexCount that looks up the parents of each vertex in the inverted graph.

countRoutes :: Graph -> [String] -> VertexCount
countRoutes _ [] = M.empty
countRoutes invGraph (r:vs) = foldl' (addCountVertex invGraph) (M.singleton r 1) vs

addCountVertex :: Graph -> VertexCount -> String -> VertexCount
addCountVertex invGraph counts v = M.insert v (sum parentCounts) counts
  where parents = invGraph ! v
        parentCounts = fmap (counts !) parents

Solving the puzzle

I put all these stages together in countRoutesBetween. It finds the subgraph, sorts it, finds the number of routes to each vertex, and finally extracts the count at the final vertex. If there's no route from here to there, the subgraph is empty and it returns zero.

countRoutesBetween :: Graph -> Graph -> String -> String -> Int
countRoutesBetween graph invGraph here there 
  | M.null subGraph = 0
  | otherwise = counts ! there
  where 
    subGraph = subGraphBetween graph invGraph here there
    invSubGraph = invertGraph subGraph
    inDegs = M.delete here $ initialInDegrees subGraph invSubGraph
    topSorted = reverse $ kahnSort subGraph inDegs [here] []
    counts = countRoutes invSubGraph topSorted

Part 1 is counting the routes from you to out. For part 2, to find the number of routes from svr to out, via both dac and fft, I count the routes from svr to dac, from dac to fft, and from fft to out, then multiply them together. I do the same but visiting fft before dac. As there are no cycles, one of the counts (dac to fft, or fft to dac) will be empty, but that means the product is zero.

part1, part2 :: Graph -> Graph -> Int
part1 graph invGraph = countRoutesBetween graph invGraph "you" "out"

part2 graph invGraph = (svrToDac * dacToFft * fftToOut) + (svrToFft * fftToDac * dacToOut)
  where 
    svrToDac = countRoutesBetween graph invGraph "svr" "dac"
    svrToFft = countRoutesBetween graph invGraph "svr" "fft"
    dacToFft = countRoutesBetween graph invGraph "dac" "fft"
    fftToDac = countRoutesBetween graph invGraph "fft" "dac"
    dacToOut = countRoutesBetween graph invGraph "dac" "out"
    fftToOut = countRoutesBetween graph invGraph "fft" "out"

Using the Data.Graph library

I then discovered the Data.Graph library and re-implemented my solution using that. It was much simpler.

The first simplification came from looking at the actual input. In my input, the vertex svr was the root of the whole graph, and out was the terminal node of the whole graph. That implied (and a quick check confirmed) that the whole graph was cycle-free. That meant I didn't need to find any relevant subgraph, as the entire graph was the subgraph.

The library also includes implementations of inverting a graph and topologically sorting it. All I had to do was convert the given graph into the array-based form used by the library.

main :: IO ()
main = 
  do  dataFileName <- getDataFileName
      text <- TIO.readFile dataFileName
      let sGraph0 = successfulParse text
      let sGraph = M.insert "out" [] sGraph0
      let (graph, _nodeFromVertex, vertexFromKey) = G.graphFromEdges $ edgify sGraph
      let invGraph = G.transposeG graph
      let sortedVs = G.topSort graph
      print $ part1 vertexFromKey invGraph sortedVs
      print $ part2 vertexFromKey invGraph sortedVs

edgify :: StringGraph -> [(String, String, [String])]
edgify graph = [(v, v, vs) | (v, vs) <- M.toList graph]

All I had left to implement was the "count the routes from" function.

countsFrom :: G.Graph -> G.Vertex -> [G.Vertex] -> VertexCount
countsFrom invGraph source vertices = foldl' go counts0 vertices
  where counts0 = M.singleton source 1
        go counts v = insertIfNeeded v (sum $ fmap (\p -> M.findWithDefault 0 p counts) (invGraph A.! v)) counts

insertIfNeeded :: G.Vertex -> Int -> VertexCount -> VertexCount
insertIfNeeded k v m 
  | M.member k m = m
  | otherwise = M.insert k v m

Solving the whole problem followed the same structure as above.

part1 :: (String -> Maybe G.Vertex) -> G.Graph -> [G.Vertex] -> Int
part1 vertexFromKey invGraph vertices = counts M.! outV
  where youV = fromJust $ vertexFromKey "you"
        outV = fromJust $ vertexFromKey "out"
        counts = countsFrom invGraph youV vertices
part2 :: (String -> Maybe G.Vertex) -> G.Graph -> [G.Vertex] -> Int
part2 vertexFromKey invGraph vertices = (svrToDac * dacToFft * fftToOut) + (svrToFft * fftToDac * dacToOut)
  where svrV = fromJust $ vertexFromKey "svr"
        outV = fromJust $ vertexFromKey "out"
        dacV = fromJust $ vertexFromKey "dac"
        fftV = fromJust $ vertexFromKey "fft"
        countsSvr = countsFrom invGraph svrV vertices
        countsDac = countsFrom invGraph dacV vertices
        countsFft = countsFrom invGraph fftV vertices
        svrToDac = countsSvr M.! dacV
        svrToFft = countsSvr M.! fftV
        dacToFft = countsDac M.! fftV
        fftToDac = countsFft M.! dacV
        dacToOut = countsDac M.! outV
        fftToOut = countsFft M.! outV

Code

You can get the code from Codeberg.