Danzer Graph

Author

Eric W. Weisstein
December 13, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/DanzerGraph.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/DanzerGraph.html.

©2023 Wolfram Research, Inc. except for portions noted otherwise

Figure

GraphicsRow[GraphData["DanzerGraph","Graph","All"]//StyleGraphs

Configuration

GraphData["DanzerGraph","Incidence"]

lines=GraphData["DanzerGraph","Configurations"]

Subscript@@Reverse@Flatten@Tally[Length/@lines[[1]]]

RecognizeGraph[LeviGraph[#]]&/@lines

GraphData["DanzerConfigurationGraph","#"]

GraphData["DanzerConfigurationGraph","EmbeddingClasses"]

GraphData["DanzerConfigurationGraph","Graph"]

configg=GraphData["DanzerConfigurationGraph","Graph",{"Configuration","Labeled"}][[1]]

configg=GraphData["DanzerConfigurationGraph","Graph",{"Labeled"}]

lines2=Sort@Select[ConfigurationLinesFromGraph[configg],Length[#]==4&]

LeviGraph[lines2]//RecognizeGraph

points=GraphEmbedding[configg]

ResourceFunction["FindExtraordinaryLines"][points]==lines2

ConfigurationGraph[points,lines2,VertexLabels->Automatic]

RecognizeGraph@%

ConfigurationDiagram[points,lines2]

Circles

pp=RootReduce[Take[GraphData["DanzerGraph","VertexCoordinates"],35]];
g1=Graphics[{Blue,Circle[pp,1],Red,PointSize@Large,Point[-pp]}]

pp=RootReduce[Take[GraphData["DanzerGraph","VertexCoordinates"],{36,70}]];
g2=Graphics[{Darker@Green,Circle[pp,1],Red,PointSize@Large,Point[-pp]}]

Show[{g1,g2}]

Embeddings

<<MathWorld`Graphs`

"DanzerGraph" == {"BipartiteKneser", {7, 3}} == {"MiddleLayer", 3}

Names

GraphData["DanzerGraph","StandardName"]

GraphData["DanzerGraph","StandardNames"]

GraphData["DanzerGraph","VertexDegrees"]

Primary

GraphData["DanzerGraph"]//StyleGraphs[#,ImageSize->Small]&

All

GraphData["DanzerGraph","Graph","All"]//StyleGraphs

Inexact

Select[GraphData["DanzerGraph","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData["DanzerGraph","EdgeList"]]

Default embedding

GraphPlot@GraphData["DanzerGraph","Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

7-fold rotationally symmetric construction

Boben et al.

data={{1,10,28},{2,45,19},{3,8,30},{4,61,69},{5,18,58},{6,67,63},{7,36,20},{8,3,49},{9,68,38},{10,51,1},{11,20,26},{12,23,67},{13,70,18},{14,57,27}};

lcf={#2-#1,#3-#1}&@@@data

g=LCFGraph[lcf,5]

RecognizeGraph@g

LCFFromEmbedding@g

g=LCFGraph[{{-29,-9},{9,15},{-15,11},{-13,5},{-27,13},{9,27},{-27,17},{5,27},{-13,-5},{-17,13},{-13,-9},{13,29},{-29,-5},{-11,29}},5,-4,VertexLabels->Automatic]

v=GraphEmbedding[g];

v[[{21,20},2]]

Middle layer construction

g=MiddleLayerGraph[3]

UnitDistanceGraphEmbeddingQ[g]

Degenerate

GraphData["DanzerGraph","Graph","Degenerate"]//StyleGraphs

Bilateral

GraphData["DanzerGraph","Graph","Circular"]//StyleGraphs

Circular

GraphData["DanzerGraph","Graph","Circular"]//StyleGraphs

Planar

GraphData["DanzerGraph","Planar"]

GraphData["DanzerGraph","Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData["DanzerGraph",{"RCN","CN"}]

GraphData["DanzerGraph","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData["DanzerGraph"],TimeConstraint->10])//AbsoluteTiming

CrossingNumber[GraphData["DanzerGraph"],TimeConstraint->60]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData["DanzerGraph"],"CrossingNumber"->cn]]

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["DanzerGraph"],"CrossingNumber"->cn,RandomSeed->n]],{n,50}],Max[OuterFace[#]]<=GraphData["DanzerGraph","V"]&]]//Timing

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["DanzerGraph","Circulant"]

GraphData["DanzerGraph","Graph","Circulant"]//StyleGraphs

Halin

GraphData["DanzerGraph","Halin"]

GraphData["DanzerGraph","Graph","Halin"]//StyleGraphs

LCF

GraphData["DanzerGraph","LCF"]

GraphData["DanzerGraph","HamiltonianCycleCount"]

GraphData["DanzerGraph","LCFSignature"]

GraphData["DanzerGraph","LCFNotations"]

GraphData["DanzerGraph","Graph","LCF"]//StyleGraphs

Tally[LCFNotation[#][[2]]&/@%]

lcf=LCFNotation/@%%

l={{"DanzerGraph",{0,Missing["NotAvailable",lcf]}}}

PropertyReplace[l,"LCFNotations","13.3"]

RenameGraphFiles[]

LCF compute random

ComputeRandomLCFNotation["DanzerGraph",2,TimeConstraint->120]

lcfs={
{{{-33,29},{-9,17},{9,33},{13,25},{-13,21},{-17,-9},{9,15},{-21,17},{-29,-13},{-25,25},{5,9},{-15,-9},{-29,-13},{-25,15},{-29,29},{-9,-5},{-13,17},{5,13},{-17,29},{-9,25},{-23,29},{-15,21},{-31,-5},{17,25},{-17,9},{-31,-21},{13,31},{5,9},{-25,-15},{-29,31},{-13,13},{9,15},{-5,23},{-17,-9},{-25,13}},2},
{{{-33,-21},{-5,11},{21,33},{-25,-9},{-23,11},{15,21},{5,17},{7,23},{11,25},{-23,-19},{-27,-13},{-5,17},{-31,-11},{-23,25},{-7,21},{-23,-11},{23,31},{9,13},{-33,27},{-27,-11},{-15,33},{-27,23},{-25,11},{-21,-17},{-25,7},{19,23},{-21,-9},{23,27},{-29,-17},{9,27},{-23,-13},{-7,5},{13,25},{-25,-11},{25,29}},2}};

LCFGraph@@@lcfs

BilateralLCFGraph/@%

LCF compute 10^5

Tally[(lcf=LCF[GraphData["DanzerGraph"],1*^5,"Prune"->True])[[All,2]]]//Timing

MaxMemoryUsed[]/10^9. GB

LCF compute 1*^6

gs=LCFGraph@@@lcf//StyleGraphs

Tally[(lcf=LCF[GraphData["DanzerGraph"],1*^6,"Prune"->True])[[All,2]]]//Timing

MaxMemoryUsed[]/10^9. GB

LCF compute 5*^6

gs=LCFGraph@@@lcf//StyleGraphs

Tally[(lcf=LCF[GraphData["DanzerGraph"],5*^6,"Prune"->True])[[All,2]]]//Timing

MaxMemoryUsed[]/10^9. GB

gs=LCFGraph@@@lcf//StyleGraphs

DeleteMissing[BilateralLCFGraph/@gs]

LCF compute 2*^7

Tally[(lcf=LCF[GraphData["DanzerGraph"],2*^7])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1|2}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,3,2])]//Timing

Length[gs]

LCF compute all

Divisors[GraphData["DanzerGraph","V"]]

Length[FindHamiltonianCycle[GraphData["DanzerGraph"],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["DanzerGraph"],All])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

Tally[(lcf=ReadProperty["LCFNotations",GraphNameToFileName["DanzerGraph",".m.gz"]])[[All,2]]]//Timing

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,1])]//Timing

Length[gs]

gs

i=0;
gs={};
t0=AbsoluteTime[];
count=Length[order2];
Monitor[
Do[
If[!MissingQ[g=BilateralLCFGraph[LCFGraph@@order2[[i]]]],AppendTo[gs,g]],
{i,count}
],
Column[{
ProgressIndicator[i,{1,count}],
Row[{i,"/",count}],
Row[{"estimated time remaining: ",Round[(AbsoluteTime[]-t0) (count/i-1)]," s"}],
Row[{Length[gs]," bilateral graphs"}]
}]
];//Timing

UnitDistance

GraphData["DanzerGraph","UnitDistance"]

UnitDistanceGraphQ[GraphData["DanzerGraph"],Debug->True]//Timing

GraphData["DanzerGraph","Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

UnitDistance by refinement

g=UnitDistanceEmbeddingRefine[Graph[Range[70],GraphData["DanzerGraph","Edges"]]]

UnitDistanceGraphEmbeddingQ[g]

Abs[EdgeLengths[g]-1]//Max

UnitDistanceEmbeddingRefine/@Complement@@(GraphData["DanzerGraph","Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData["DanzerGraph"],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData["DanzerGraph"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData["DanzerGraph"],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{"DanzerGraph",l=FindSubgraphUnitDistanceEmbedding[GraphData["DanzerGraph"];GraphData[{"BipartiteKneser",{7,3}}],TimeConstraint->300,"Results"->All]//Timing}

gs=SortBy[UniqueEmbeddings[l],Replace[RectilinearCrossingCount[#],Infinity->0]&]

Matchstick

GraphData["DanzerGraph","Matchstick"]

GraphData["DanzerGraph","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["DanzerGraph","Edges"]]

3D All

GraphData["DanzerGraph","Graph",{"3D","All"}]

3D UnitDistance

GraphData["DanzerGraph","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["DanzerGraph","Polyhedral"]

GraphData["DanzerGraph","Graph",{"3D","Polyhedron"}]

Construction

Bipartite double of (Subscript[O, 4])

g=BipartiteDoubleGraph[OddGraph[4]]

BipartiteDoubleGraph[OddGraph[4]]//RecognizeGraph

BipartiteKener

BipartiteKneserGraph[7,3]

RecognizeGraph[%]

StackExchange

https://math.stackexchange.com/questions/4565282/does-the-middle-layer-graph-have-a-nice-embedding

red=Subsets[Range[7],{3}];
black=Subsets[Range[7],{4}];
g=IndexGraph@Graph[Flatten@Table[r\[UndirectedEdge]Union[r,{i}],{r,red},{i,Complement[Range[7],r]}],VertexCoordinates->Table[v->Total[CirclePoints[7][[v]]],{v,Join[red,black]}],VertexStyle->Join[Thread[red->Red],Thread[black->Black]]]

RecognizeGraph@g

Wikipedia

g=Import["https://upload.wikimedia.org/wikipedia/commons/9/99/Danzer_graph.svg"]

str=Import["https://upload.wikimedia.org/wikipedia/commons/9/99/Danzer_graph.svg","String"]

ptstr=StringCases[str,Shortest[" "..~~"x=\""~~x__~~"\""~~__~~"xlink:href="~~__~~"y=\""~~y__~~"\""]:>{x,y}]

Length[ptstr]

v=ToExpression/@ptstr

u=EuclideanDistance@@v2[[{56,20}]]

v2=(#-Mean[v])&/@v/u;

ee=UnitEdges[v2]

g0=CenterGraph@Graph[Range[Length[v2]],ee,VertexCoordinates->v2,VertexLabels->Automatic,Axes->True]

RecognizeGraph[g0]

v0=GraphEmbedding[g0];

Refine

(g2=CenterGraph@UnitDistanceEmbeddingRefine[g,WorkingPrecision->20])//Timing

(g3=RotateGraph[CenterGraph@UnitDistanceEmbeddingRefine[g,WorkingPrecision->50],{39,23}])//Timing

ArcTan@@Subtract@@v3[[{39,23}]]-Pi

Mean[v3=GraphEmbedding[g3]]

?ToAlgebraicRoot

ToAlgebraicRoot[v4[[1,1]],"MaxDegree"->12,WorkingPrecision->50]

ToAlgebraicRoot[v4[[1,2]],"MaxDegree"->12,WorkingPrecision->45]

Compute from circles

v=Join[a1 CirclePoints[14], CirclePoints[{a2,q},14],CirclePoints[{a2,-q},14],a3 CirclePoints[14],a4 CirclePoints[14]];

rules={a1->v0[[23,1]],a2->Norm[v0[[69]]],a3->v0[[25,1]],a4->v0[[15,1]],q->ArcTan@@v0[[69]]}

v1=v/.rules;

ee=UnitEdges[v1]

RecognizeGraph[Graph[ee]]

(eqn=FullSimplify[UnitEdgeEquations[v,ee]]//Union)//Column

Solve[4 (a1^2) ((Sin[(π/14)])^2)==1,a1,PositiveReals]//FullSimplify

N[%]

Solve[4 (a3^2) ((Sin[((3 π)/14)])^2)==1,a3,PositiveReals]//FullSimplify

N[%]

Solve[4 (a4^2) ((Cos[(π/7)])^2)==1,a4,PositiveReals]//FullSimplify

N[%]

eqn2=DeleteCases[eqn/.{a1->(1/2) Csc[(π/14)],a3->(1/2) Csc[((3 π)/14)],a4->(1/2) Sec[(π/7)]}//FullSimplify//Union,True]

Subtract@@@eqn2/.rules

eqn3=(TrigExpand[eqn2]//RootReduce//FullSimplify//Union)/.{Cos[q]->c,Sin[q]->s}

GroebnerBasis[Append[Subtract@@@eqn3,c^2+s^2-1],{a2},{c,s}]//RootReduce

Solve[%==0,a2,PositiveReals]

GroebnerBasis[Append[Subtract@@@eqn3,c^2+s^2-1],{c},{a2,s}]//RootReduce

Solve[%==0,c,PositiveReals]//RootReduce

FullSimplify[ArcCos[(NumericalApproximation[Root, (RowDefault["0.991", FEExpressionsNumericalApproximationElider]), Root[-1+136 ((#1)^2)-640 ((#1)^4)+512 ((#1)^6)&,6], ])]]

vexact=v/.{a1->(1/2) Csc[(π/14)],a2->(Sqrt[2]),a3->(1/2) Csc[((3 π)/14)],a4->(1/2) Sec[(π/7)],q->ArcCos[(NumericalApproximation[Root, (RowDefault["0.991", FEExpressionsNumericalApproximationElider]), Root[-1+136 ((#1)^2)-640 ((#1)^4)+512 ((#1)^6)&,6], ])]}//FullSimplify

vexact2=RootReduce[vexact]//FullSimplify

gexact=Graph[Range[70],ee,VertexCoordinates->vexact2]

ToAlgebraicRoot/@EdgeLengths[gexact]//Union

GraphData

GraphDataClass

GraphDataClassString["DanzerGraph"]