6

How can I generate all labelled connected simple graphs on n vertices?

In the image below, I drew examples with number of vertices n = 3 and n = 4.

For n = 3, there are only 4 graphs that connect all vertices.
For n = 4, I only drew some as there are many more so did not draw all here.

I would like to create a function that if I input the number of vertices then it generates all graphs like the image below.

Any idea to do this?

The layout of graphs is not important but I want to label vertices's names with number or letters. Self-loop is not possible and there is only one edge between two vertices.

enter image description here

Szabolcs
  • 234,956
  • 30
  • 623
  • 1,263
hana
  • 2,388
  • 5
  • 19

3 Answers3

7

For small $n$, one can use:

allEdges[n_]:=Flatten[Table[UndirectedEdge[i,j],{i,1,n},{j,i+1,n}]];
allConnected[n_]:=Select[Map[Graph[Range[n],#,VertexLabels->Automatic]&,
                             Subsets[allEdges[n]]],ConnectedGraphQ];
allConnectedUpToIso[n_]:=DeleteDuplicates[allConnected[n],IsomorphicGraphQ];

Example:

allConnectedUpToIso[4]

enter image description here

user293787
  • 11,833
  • 10
  • 28
  • Thanks, but that doesn't create all graphs like I mentioned above. Two graphs with same shape but vertices different are considered different in my case. – hana Nov 08 '22 at 17:59
  • 1
    Please try allConnected[4], it will return all those graphs. – user293787 Nov 08 '22 at 18:01
  • I see, thank you. – hana Nov 08 '22 at 18:04
  • Better practice is to accept the answer if it answers what you asked instead of writing "thank you". – azerbajdzan Nov 08 '22 at 21:35
  • 1
    In general, DeleteDuplicates[list, IsomorphicGraphQ] is very inefficient. The better way to do this is DeleteDuplicatesBy[list, CanonicalGraph]. However, OP was asking for labelled graphs. – Szabolcs Nov 08 '22 at 21:52
5

A hopefully efficient approach to generate all possible adjacency matrices as bit fields. In a first step, we filter those which have a sufficient number of edges to be connected. In a second step, we filter connected graphs.

In[161]:= 
n = 5; (* no of vertices *)
k = n (n - 1)/2; (* max number of edges *)

In[163]:= symmetrize = # + Transpose[#] &;


In[164]:= 
adjmats = 
  symmetrize@PadRight[TakeList[#, Range[n] - 1], {n, n}] & /@ 
   IntegerDigits[Range[2^k] - 1, 2, k];


In[165]:= graphs = Select[
   AdjacencyGraph /@ Select[adjmats, Total[#, 2]/2 >= n - 1 &],
   ConnectedGraphQ
   ];


In[166]:= Length[graphs]
Out[166]= 728

We can convince ourselves that the code is correct by comparing counts with https://oeis.org/A001187

I did not benchmark this against other solutions.

Szabolcs
  • 234,956
  • 30
  • 623
  • 1,263
  • Somehow this is slower than the user293787's answer on my laptop using AbsoluteTiming. user293787's method takes 0.0930639 and this method takes 0.2760455 for 5 vertices. – hana Nov 09 '22 at 04:20
  • The link is interesting. – hana Nov 09 '22 at 08:03
  • It's interesting that this is slower. I don't have the time to look into why, but I suspect that in Mathematica building a graph from an adjacency matrix is just slower than building one from an edge list. – Szabolcs Nov 09 '22 at 13:30
4

Edit:

This is probably not what OP meant (as pointed out by @user293787) but I understood it as all vertices have to be connected somewhere instead of all vertices have to be connected together. If it was the former case my answer would be:

n = 4;
Graph[Range[n], UndirectedEdge @@@ #, VertexLabels -> Automatic, 
   VertexCoordinates -> CirclePoints[n], ImageSize -> 50] & /@ 
 Select[Subsets[Subsets[Range[n], {2}], {Floor[n/2], ∞}], 
  Length[Union[Flatten[#]]] == n &]
Clear[n]

enter image description here

enter image description here

And just a small portion of all 768 graphs for n=5 (for n=6 there is already 27449 graphs):

enter image description here

And this is for the latter case (selection by ConnectedGraphQ added to previous code):

n = 4;
Select[Graph[Range[n], UndirectedEdge @@@ #, 
    VertexLabels -> Automatic, VertexCoordinates -> CirclePoints[n], 
    ImageSize -> 50] & /@ 
  Select[Subsets[Subsets[Range[n], {2}], {Floor[n/2], \[Infinity]}], 
   Length[Union[Flatten[#]]] == n &], ConnectedGraphQ]
Clear[n]
azerbajdzan
  • 15,863
  • 1
  • 16
  • 48
  • 1
    Maybe I misunderstood the requirements. I took it as any vertex must be connected somewhere, not that all vertices have to me connected together. – azerbajdzan Nov 08 '22 at 20:25
  • Sorry for the confusion, I actually meant to say all vertices connected together. – hana Nov 08 '22 at 21:04