List all homeomorphically distinct irreducible connected simple acyclic graphs of size 10 ("Good Will Hunting" problem)

Question

In the movie Good Will Hunting the opening math problem is:

• Display all homeomorphically distinct irreducible connected simple acyclic graphs (trees) of size $n =10$

Recall that a tree (acyclic graph) is a graph without loops. "Irreducible" means that there are no vertices of order 2... that is, no vertices that can be eliminated, its edges linked, and the rest of the graph remains unchanged. "Homeomorphically distinct" simply means that the graph layout or embedding into the plane does not matter. "Simple" means at most one edge between any two vertices and no "loops" (edges from a vertex to itself). "Connected" of course means that there is a path from any vertex to any other vertex through the graph.

It turns out that there are 10 such graphs in the solution set, including these three:

What is the tersest Mathematica code that generates all 10 graphs? The tricky part for me is the condition of irreducibility, as there seem to be no simple function calls to identify or eliminate reducible graphs. VertexDegree, of course, will help here.

My preference would be for some generative algorithm, but I suspect the tersest is to generate many candidate graphs and select the solution graphs among them.

I'd love to have code that naturally generalizes to arbitrary $n$, but that isn't part of this problem.

Answer 1

Instead of doing a twisted form of search, like my other answer, this is a perverted form of hard coding:

Join[KaryTree[10, #] & /@ {5, 6, 7, 9}, 
 ExpressionGraph /@ 
  Join[Groupings[7, {3, Orderless}],
   { 2π*a√b√c , 2a+3b+4c , 2a+b+d√c , a[2π(a+√b)z] }
]]

None of the whitespace is necessary. It can surely be improved, but currently I count 124 characters (with π and √ counting once each).

The KaryTree's get 4 of them, the Groupings get another 2, and I mash the 4 others in.

Answer 2

If you're willing to use some brute force, we can borrow ideas from here: https://mathematica.stackexchange.com/a/240803/4346

irreducibleGraphQ[g_] := Total[Unitize[VertexDegree[g] - 2]] == VertexCount[g]

<<IGraphM`;

takeHalf[list_] := Take[list, Ceiling[Length[list]/2]]

n = 10;

candidates = Sort[Join @@ Table[
  takeHalf@Select[Tuples[Range[k], {n - 2}], Length@Union[#] == k &],
  {k, n - 2}
]]; // AbsoluteTiming

{41.56, Null}

Length[candidates]

272918

found = <||>;
Monitor[
  Do[
    g = IGFromPrufer[k];
    If[irreducibleGraphQ[g],
      found[EdgeList[CanonicalGraph[g]]] = True
    ],
    {k, candidates}
  ],
  k
] // AbsoluteTiming

{33.9122, Null}

Graph[Range[n], #] & /@ Keys[found]

Answer 3

Update: TDIL from Eric Weisstein's answer that, thanks to updates to GraphData in versions 12.+, we can use GraphData to get the desired result fast and with a short code.

A variation to Eric's answer that shaves about 10 characters:

Select[# /@ #["Tree", 10]& @ GraphData, FreeQ[2] @* VertexDegree]

StringLength @ "Select[#/@#[\"Tree\",10]&@GraphData,FreeQ[2]@*VertexDegree]"

57 

Original answer:

SeedRandom[3];

Union @ Select[CanonicalGraph @* UndirectedGraph /@ RandomTree[10,340], 
  FreeQ[2] @* VertexDegree]

Multicolumn[%, 5] 

StringLength @ "SeedRandom[3];Union@Select[CanonicalGraph@*UndirectedGraph/@
 RandomTree[10,340],FreeQ[2]@*VertexDegree]"

102

We can get rid of SeedRandom[3] and increase sample size to get a shorter but slower version (which we might have to execute more than once to get 10 graphs):

StringLength @ "Union@Select[CanonicalGraph@*UndirectedGraph/@RandomTree[10,10^4],
FreeQ[2]@*VertexDegree]"

89

Answer 4

Brute force, and nondeterministic

NestWhile[l \[Function] 
 If[
    FreeQ[VertexDegree@#, 2] \[And]
    TreeGraphQ@# \[And] 
    And @@ Table[\[Not] IsomorphicGraphQ[G, #], {G, l}]
  ,l~Append~#,l
 ] &@RandomGraph@{10, 9}
, {}, Length@# < 10 &]

With \[And], \[Not] and \[Function] counted as one character, I count 149 characters when removing the unnecessary whitespace (all whitespaces).

I swear it worked immediately on my computer :)

Test with Or @@ IsomorphicGraphQ @@@ Subsets[%, {2}]

Answer 5

With[{g=GraphData},g/@Select[g["Tree",10],FreeQ[g[#,"Degrees"],2]&]]