Solution en Haskell

Tout d'abord, remarquons que ce problème peut être partiellement résolu à la main en repérant les trois arêtes à supprimer à l'aide d'un outil de visualisation comme GraphViz.

C'est ce que j'ai fait pour le résoudre vite mais ce n'est pas très rigolo. Comme je préférais avoir un programme qui résout tout automatiquement, j'ai cherché un algorithme pour ce problème qui s'avère s'appeler un Minimum (Edge) Cut.
J'ai cherché une librairie en Haskell qui faisait ça mais n'en ayant pas trouvé, j'ai décidé d'implémenter moi même un algorithme.

Je suis tombé sur celui de Stoer et Wagner (qui fonctionne aussi sur un graphe pondéré).

https://en.wikipedia.org/wiki/Stoer%E2%80%93Wagner_algorithm

Ca n'a pas été facile de l'implémenter car la page wikipedia ne montre que les grandes lignes de l'algorithme mais je suis content de mon résultat.

Ca tourne en 2.5s sur l'input alors que la librairie Python networkx tourne en 6s pour le même problème.
Comme le code est un peu long, je ne le poste pas ici mais vous pouvez le trouver à cette adresse:
https://github.com/gbagan/advent-of-code/blob/master/libraries/aoc/AOC/Graph/MinCut.hs

Je me demande si il existe de meilleurs algorithmes quand on sait que le minimum cut est petit (ici 3).

Pour le code du problème à proprement parler, c'est assez court en utilisant une fonction pour le Minimum Cut et une pour trouver les composantes connexes.

type Network = [(Text, [Text])] 
parser :: Parser Network
parser = row `sepEndBy1` eol where
 row = (,) <$> label <* ": " <*> label `sepEndBy1` hspace
 label = Text.pack <$> some lowerChar 
part1 :: Network -> Int
part1 network = product (map length components) where
 graph = foldl' (\g (u, v) -> addEdge u v g) Map.empty
 [(u, v) | (u, nbor) <- network, v <- nbor]
 cutset = minimumCut graph
 graph' = foldl' (\g (u, v) -> removeEdge u v g) graph cutset
 components = connectedComponents graph'