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

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.

• When you say terse, do you mean short or concise? I see 4 methods to solve this problem: (1) hard code the answers, (2) look up the answers, (3) generate and filter graphs with no rhyme or reason (i.e. random or all of them), or (4) actually solve the problem by generating graphs intelligently. To specify any intelligent algorithm requires too many characters, if this is code golf.
Mar 25, 2022 at 18:00
• Terse = few characters. Seeking solution types (3) or (4). Mar 25, 2022 at 19:31
• Separately: If Mathematica has an Inorganic-Chemistry module, you might get this by having it plot the set of 10-member acyclic isomers with coordination-numbers { =1, >2 }.
– Nat
Mar 26, 2022 at 16:46

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.

• Alas, that code doesn't run on v. 11.3. (I suspect ExpressionGraph is the culprit.) But looks cool! Mar 24, 2022 at 3:22
• Blast! Try with TreeForm instead of ExpressionGraph. Would it still be valid with Graph and Graphics objects intermixed?
Mar 24, 2022 at 3:28
• IGraph/M has had IGExpressionTree since much before ExpressionGraph was introduced, and works in old versions of Mathematica Mar 24, 2022 at 7:29
• @DavidG.Stork, you can use GraphComputationExpressionGraph in version 11.3.
– kglr
Mar 24, 2022 at 9:16
• How do you like those Apples? ;) Apr 21, 2022 at 14:19

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] • Great ($+1$). I'll wait to see if anyone posts a shorter code before I accept. Thanks! Mar 24, 2022 at 1:56

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.

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

57


SeedRandom;

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

Multicolumn[%, 5] StringLength @ "SeedRandom;Union@Select[CanonicalGraph@*UndirectedGraph/@
RandomTree[10,340],FreeQ@*VertexDegree]"

102


We can get rid of SeedRandom 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@*VertexDegree]"

89

• This is best (a hearty $+1$).... I should have known to wait for the extraordinary kglr's answer before accepting! Mea maxima culpa. Mar 24, 2022 at 16:20
• Thank you @DavidG.Stork. Eric's answer using GraphData is both shorter and faster. It works in version 13.0. (In version 11.3.0 GraphData["Tree" 10] gives a shorter list of graphs).
– kglr
Mar 24, 2022 at 17:39
• you can always change the accepted answer. Mar 25, 2022 at 10:32

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}]

• Great ($+1$). I'll wait to see if anyone posts a shorter code before I accept. Thanks! Mar 24, 2022 at 1:54
• What if we did not know beforehand that there are no more than ten of them? Mar 27, 2022 at 7:42
• Without this assumption, none of my answers are valid
With[{g=GraphData},g/@Select[g["Tree",10],FreeQ[g[#,"Degrees"],2]&]]