16
$\begingroup$

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:

Three solution graphs

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.

$\endgroup$
3
  • $\begingroup$ 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. $\endgroup$
    – Adam
    Mar 25, 2022 at 18:00
  • $\begingroup$ Terse = few characters. Seeking solution types (3) or (4). $\endgroup$ Mar 25, 2022 at 19:31
  • 1
    $\begingroup$ 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 }. $\endgroup$
    – Nat
    Mar 26, 2022 at 16:46

5 Answers 5

13
$\begingroup$

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.

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

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]

enter image description here

$\endgroup$
1
  • $\begingroup$ Great ($+1$). I'll wait to see if anyone posts a shorter code before I accept. Thanks! $\endgroup$ Mar 24, 2022 at 1:56
14
$\begingroup$

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]

enter image description here

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] 

enter image description here

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
$\endgroup$
3
  • $\begingroup$ This is best (a hearty $+1$).... I should have known to wait for the extraordinary kglr's answer before accepting! Mea maxima culpa. $\endgroup$ Mar 24, 2022 at 16:20
  • $\begingroup$ 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). $\endgroup$
    – kglr
    Mar 24, 2022 at 17:39
  • 3
    $\begingroup$ you can always change the accepted answer. $\endgroup$
    – Rainb
    Mar 25, 2022 at 10:32
11
$\begingroup$

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 :)

all graphs

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

$\endgroup$
3
  • 1
    $\begingroup$ Great ($+1$). I'll wait to see if anyone posts a shorter code before I accept. Thanks! $\endgroup$ Mar 24, 2022 at 1:54
  • 1
    $\begingroup$ What if we did not know beforehand that there are no more than ten of them? $\endgroup$ Mar 27, 2022 at 7:42
  • $\begingroup$ Without this assumption, none of my answers are valid $\endgroup$
    – Adam
    Mar 27, 2022 at 18:12
8
$\begingroup$
With[{g=GraphData},g/@Select[g["Tree",10],FreeQ[g[#,"Degrees"],2]&]]
$\endgroup$
6
  • $\begingroup$ But this doesn't solve the problem... right? $\endgroup$ Mar 24, 2022 at 16:19
  • 1
    $\begingroup$ @DavidG.Stork unless I'm missing something, this answer produces the same graphs as the accepted answer. $\endgroup$
    – Jason B.
    Mar 24, 2022 at 18:58
  • 1
    $\begingroup$ @David, it works in version 13.0.0 (but not in version 11.3.0) $\endgroup$
    – kglr
    Mar 24, 2022 at 19:00
  • 1
    $\begingroup$ In 12.1 it doesn't output them all, so perhaps 12.2 or 12.3 makes this work. I went and looked up the definition of terse in the dictionary -- this code is terse! (+1) $\endgroup$
    – Adam
    Mar 24, 2022 at 21:16
  • 1
    $\begingroup$ @JasonB. I took David's point to be that this doesn't solve the problem; rather, it looks up an answer to the problem. Personally, I think this answer is clearly relevant but I can see why David might not mark it as accepted. $\endgroup$ Mar 25, 2022 at 10:23

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.