Wolfram Cloud Document

Introduction

Animations and graphs based on the Wolfram Community post (and comments) “OpenAI disproves Erdős unit distance conjecture", [EPn1]. The graph creation code below is a modified version of code provided by Shenghui Yang in [EPn1]. For theoretical details about the unit distance graph edges problem see [PE1, EPn1].

Procedure outline

Try to figure out neat examples to visualize graphs related to Erdős unit distance conjecture.

Program a few versions of formula-based visualization routines.

Marvel at corresponding graphs.

Especially, the ones obtained with larger parameters.

(Try to) make a collection of them.

Come up with a (much) faster computation routine in order to have a functional Manipulate interface.

Consider making

Graph objects (not just points and lines connecting them)

More interesting graph-plots by coloring the vertices according to certain criteria

An animation of the graph-plot collection

Make the animations and try to marvel at them.

Not that good because the animations “blink.”

The reason is graph-outliers that have too few edges, or plot ranges that are too different from the rest of the graphs.

“Clean” the graph collection

Find and investigate graph outliers with too few edges.

Find and investigate graphs with plot ranges that are too small or too large

Do not do the investigation if the number of outliers is too small.

The outlier graphs can be just removed from the animation collection.

(Outliers have to be explained. Usually. There are more important things to do than some graph animations.)

Export the graph-plot animation to a movie and a GIF and upload them.

Make a blog post (notebook).

Definitions

Here is a fast(er) definition for making unit distance graphs with a complex numbers formula:

In[]:=

Clear[UnitDistanceGraphEdges];UnitDistanceGraphEdges[α_?NumericQ,m_?IntegerQ]:=Block[{conn,ω,r,pt,nf,aVertexToIndex,aVertexCoords,lsEdges},ω=-0.5+α*I;r=Range[-m,m,1];pt=Table[a+b*I+c*ω+d*I*ω,{a,r},{b,r},{c,r},{d,r}]//Flatten;pt=ReIm/@pt;nf=Nearest[pt];conn=Association@Map[Function[p,p->Select[nf[p,{All,1.01}],Abs[1-EuclideanDistance[#,p]]≤10^-5&]],pt];conn=Select[conn,Length[#]>0&];conn=Union[Sort/@Flatten[KeyValueMap[Function[{k,v},{k,#}&/@v],conn],1]];aVertexToIndex=AssociationThread[#,Range@Length@#]&@Union[Flatten[conn,1]];aVertexCoords=Association[Rule@@@Map[Reverse,List@@@Normal[aVertexToIndex]]];lsEdges=conn/.aVertexToIndex;<|"Edges"->lsEdges,"VertexCoordinates"->aVertexCoords,"VertexToIndex"->aVertexToIndex|>];

Remark: See the comments in [EP1] for the original and related definitions.

Manipulate

In[]:=

DynamicModule{aRes,conn},ManipulateaRes=UnitDistanceGraphEdges[α,m];conn=aRes["Edges"]/.aRes["VertexCoordinates"];ColumnFormRow[{"Number of edges:",Spacer[5],Length@conn}],ListPlotValues@aRes["VertexCoordinates"],

,α,

2.,"angle:",0,2,0.01,Appearance->"Open",{{m,2,"boundary:"},1,6,1,Appearance->"Open"},SaveDefinitions->True

Out[]=

angle:

0.866025

boundary:

Number of edges:

2800

Using graphs

Instead of just plotting the points and connecting them with lines, we can make actual graph objects, and use them to make graph-plots or conduct certain type of analysis. Here the elements of a nice unit graph are computed:

In[]:=

AbsoluteTimingaRes=UnitDistanceGraphEdges

2.,3;

Out[]=

{0.334242,Null}

Here is the graph objects and basic information for it:

In[]:=

g=Graph[aRes["Edges"],VertexCoordinates->aRes["VertexCoordinates"]];Information[g]

Out[]=

Graph

Vertex Count	2401
Edge Count	11760
Directed	False
Weighted	False

Here is the vertex degree distribution:

In[]:=

Histogram[VertexDegree[g],Automatic,PlotRange->All,PlotTheme->"Detailed"]

Out[]=

Find the vertex degrees, make a highlight spec with, and plot the corresponding highlighted graph:

In[]:=

lsHighlight=Values@SortBy[GroupBy[AssociationThread[VertexList[g],VertexDegree[g]],#&,Keys],Length];GraphPlot@HighlightGraph[g,lsHighlight,ImageSize->800,VertexSize{"Scaled",0.006}]

Out[]=