The following is a brute force solution, but it is easy to understand:
This is the starting graph:
g0 = Graph[{"a" -> "b", "c" -> "d", "e" -> "f"}];
You want to contract vertices in all possible ways. For simplicity, we will use IGVertexContract
from IGraph/M, as it can handle multiple contractions simultaneously.
Needs["IGraphM`"]
Contracting the two endpoints of an existing edge (such as a -> b
) is not allowed:
vertices = VertexList[g0]
disallowed = Partition[vertices, 2]
(* {{"a", "b"}, {"c", "d"}, {"e", "f"}} *)
These are the allowed contractions:
possibleContractions = Complement[Subsets[vertices, {2}], disallowed]
(* {{"a", "c"}, {"a", "d"}, {"a", "e"}, {"a", "f"}, {"b", "c"},
{"b", "d"}, {"b", "e"}, {"b", "f"}, {"c", "e"}, {"c", "f"},
{"d", "e"}, {"d", "f"}} *)
We can get all combinations with Subsets[possibleContractions]
. However, given a vertex, we may only contract it with one other vertex, not multiple one. Thus, we need a helper function to detect multiple contractions:
disjointQ[list_] := Length[Union @@ list] == Length[Join @@ list]
These are the allowed contractions: Select[Subsets[possibleContractions], disjointQ]
.
IGVertexContract[g0, #, GraphStyle -> "VintageDiagram"] & /@
Select[Subsets[possibleContractions], disjointQ]
Here's a screenshot of the first few results:
Note that graphs with reciprocal edges are also generated. You did not make it clear if you need them. If not, just filter them out.
Graph[{1 \[DirectedEdge] 2, 2 \[DirectedEdge] 3, 3 \[DirectedEdge] 1}]
$\endgroup$