Advent of Code 2024 day 23

Day 23 was one of looking up standard algorithms from graph theory and implementing them.

I tried using the Data.Graph library, but it didn't allow for incremental building of a graph and didn't provide any functions useful for this problem, so I built my own.

data Edge = Edge String String
  deriving (Show, Eq, Ord)

type Vertex = String
type Vertices = S.Set Vertex
type Graph = M.Map Vertex Vertices
type Clique = [Vertex]

I read the input with attoparsec (rather than thinking about it) and build the graph from the edges. Each (undirected) edge of the input turns into two direct edges in the Graph structure.

edgesP = edgeP `sepBy` endOfLine
edgeP = Edge <$> (many1 letter) <* string "-" <*> (many1 letter)

mkGraph :: [Edge] -> Graph
mkGraph edges = M.fromListWith S.union $ fmap (\(Edge a b) -> (a, S.singleton b)) biEdges
  where biEdges = edges ++ fmap (\(Edge a b) -> Edge b a) edges

Part 1

This is a standard problem in graph theory. The wikipedia entry says that finding k-size cliques is generally found by finding all sets of k vertices and checking if they're a complete graph. The tuples function from the Combinatorics library finds sets of k vertices, and the Copilot tool suggested a decent implementation of the test for completeness.

part1 :: Graph -> Int
part1 graph = length $ filter couldBeHistorian $ find3Cliques graph

find3Cliques :: Graph -> [[Vertex]]
find3Cliques graph = filter isClique possibles
  where possibles = tuples 3 $ M.keys graph
        isClique [a,b,c] = b `S.member` (graph M.! a) && c `S.member` (graph M.! a) && c `S.member` (graph M.! b)
        isClique _ = False

couldBeHistorian :: [Vertex] -> Bool
couldBeHistorian cliques = any ((== 't') . head) cliques

Part 2

Finding the largest maximal clique boils down to finding the maximal cliques, then finding which of those is largest. However, I had difficulty following the description of the Bron-Kerbosch algorithm, as I wasn't sure when new contexts were introduced. I had a look around for other explanations, and came across a student report looking at the effects of parallelisation in Haskell programs, using the Bron-Kerbosch algorithm as the testbed (Wang & Yin 2023?). So I lifted the implementation they presented in their report, and it worked! (I rearranged their code slightly to make the sub-functions all defined at the top level, but that was all.)

getMaximalCliques :: Graph -> [Clique]
getMaximalCliques graph = bronKerbosch graph [] (M.keys graph) [] 

bronKerbosch :: Graph -> Clique -> [Vertex] -> [Vertex] -> [Clique]
bronKerbosch graph partialClique candidateVertices excludedVertices
  | null candidateVertices && null excludedVertices = [ partialClique ]
  | otherwise = exploreCandidates graph partialClique candidateVertices excludedVertices

exploreCandidates :: Graph -> Clique -> [Vertex] -> [Vertex] -> [Clique]
exploreCandidates _ _ [] _ = []
exploreCandidates graph partialClique (currentVertex : remainingCandidates) currentExcluded =
  bronKerbosch graph 
                (currentVertex : partialClique)
                (restrictVertices graph remainingCandidates currentVertex)
                (restrictVertices graph currentExcluded currentVertex) ++
  exploreCandidates graph partialClique remainingCandidates ( currentVertex : currentExcluded)

restrictVertices :: Graph -> [Vertex] -> Vertex -> [Vertex]
restrictVertices graph curvertices vertex = filter ( isConnected graph vertex ) curvertices

isConnected :: Graph -> Vertex -> Vertex -> Bool
isConnected graph a b = b `S.member` (graph M.! a)

Given that I can find all maximal cliques, finding the largest is simple.

part2 :: Graph -> String
part2 graph = intercalate "," $ sort maxClique
  where maxClique = maximumBy (compare `on` length) $ getMaximalCliques graph

Code

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