Voronov-Neopryatnaya-Dergachev Graphs

Author

Eric W. Weisstein
August 16, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Voronov-Neopryatnaya-DergachevGraphs.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Voronov-Neopryatnaya-DergachevGraphs.html.

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

Graphic

VoronovNeopryatnayaDergachev=SortBy[GraphData["VoronovNeopryatnayaDergachev*"],(ToExpression[StringCases[#,DigitCharacter..][[1]]]&)]

bug(342624): TextCell[..., PageWidth -> 50, Hyphenation -> True] fails to hyphenate
bug(422923): GraphicsRow/GraphicsGrid cut off plot label text

GraphicsRow[Show[GraphData[#,"Graph","3D"],PlotLabel->TextCell[Style[GraphData[#,"Name"],Directive[16,Black,Italic,FontFamily->"Times New Roman",Hyphenation->True]],PageWidth->300,TextAlignment->Center]]&/@VoronovNeopryatnayaDergachev,Dividers->All,ImageSize->800]

"VoronovNeopryatnayaDergachevGraph372"

Embeddings

GraphData["VoronovNeopryatnayaDergachevGraph372","StandardName"]

Default

GraphData["VoronovNeopryatnayaDergachevGraph372"]

All

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

Circular

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

Halin

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

LCF

GraphData["VoronovNeopryatnayaDergachevGraph372","LCF"]

GraphData["VoronovNeopryatnayaDergachevGraph372","Regular"]

GraphData["VoronovNeopryatnayaDergachevGraph372","LCFSignature"]

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

UnitDistance

GraphData["VoronovNeopryatnayaDergachevGraph372","UnitDistance"]

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

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

Matchstick

GraphData["VoronovNeopryatnayaDergachevGraph372","Matchstick"]

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

MinimalCrossing

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

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

Default embedding

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

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

RecognizeGraph[g]

MinimalCrossing construction

CrossingNumber[GraphData["VoronovNeopryatnayaDergachevGraph372"],TimeConstraint->10]//AbsoluteTiming

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

CrossingNumber[GraphData["VoronovNeopryatnayaDergachevGraph372"],TimeConstraint->300]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData["VoronovNeopryatnayaDergachevGraph372"],"CrossingNumber"->-1]]

RecognizeGraph[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["VoronovNeopryatnayaDergachevGraph372","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["VoronovNeopryatnayaDergachevGraph372","Polyhedral"]

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

Construction

Code greatly sped up and streamlined  from:

https://github.com/vsvor/dist-graphs/

(*  Checking the existence of the 5-chromatic 372-vertex unit distance graph
embedded in the circumsphere of the icosahedron with unit edge lengths. 
Vsevolod Voronov, Anna Neopryatnaya, Eugene Dergachev 
  e-mail: v-vor@yandex.ru        *)
(*  code from this page 
https://mathandcode.com/2016/06/06/polyhedramathematica.html 
 is used to generate symmetry group *)

(* Numerically check if any matrix is the zero matrix to within some accuracy *)
isZeroMatrix[r_]:=(Flatten[N[r]].Flatten[N[r]]<0.00001);

(* Numerically test and remove duplicate matrices from a list *)
reduce[list_]:=Union[list,SameTest->(isZeroMatrix[#1-#2]&)];

(* Given a list of square matrices g, this function combines all possible pairs of matrices in all possible orders, and numerically removes all duplicate matrices *)
iterate[g_]:=reduce[FullSimplify[#1.#2]&@@@Tuples[g,2]];

(* Given a generating set of matrices, this function creates a group. If the generators aren't actually a generating set, 
this code runs forever! *)
makeGroup[generators_]:=FixedPoint[iterate,Join[generators,{IdentityMatrix[3]}]];

orbit[point_,group_]:=reduce[#.point&/@group];

(* icosahedron symmetry group elements *)
(* order = 120 *)
f=(1+Sqrt[5])/2;
icoGenerators={{{-1,0,0},{0,-1,0},{0,0,1}},{{0,0,1},{1,0,0},{0,1,0}},(1/2 {{1,-f,1/f},{f,1/f,-1},{1/f,1,f}}),{{1,0,0},{0,-1,0},{0,0,1}}};
Length[icoG=makeGroup[icoGenerators]]//Timing

(* 12 icosahedron vertices *)
v= {(Sqrt[5]+1)/4,1/2,0};
Length[icosV=orbit[v,icoG]]

(* using 3 points from the embedding of the 9-vertex unit distance graph we compute 3*120 vertices  *)
v11 = (1/4) (1+(Sqrt[-1+2 (Sqrt[5])]));
v12 =(1/8) (-1-(Sqrt[5])+2 (Sqrt[(7/2)+((5 (Sqrt[5]))/2)])) ;
v13 = (1/4) (Sqrt[5-3 (Sqrt[5])+(Sqrt[2 (7+5 (Sqrt[5]))])]);
v21=Root[1+8 #1+9 ((#1)^2)-7 ((#1)^3)+28 ((#1)^4)+6 ((#1)^5)-4 ((#1)^6)-((#1)^7)+((#1)^8)&,2]/2;
v22=Root[-1-5 #1+5 ((#1)^2)-4 ((#1)^3)+9 ((#1)^4)-5 ((#1)^5)+((#1)^6)-2 ((#1)^7)+((#1)^8)&,1]/2;
v23=Root[-1+7 #1-13 ((#1)^2)-24 ((#1)^3)+4 ((#1)^4)+10 ((#1)^5)-3 ((#1)^7)+((#1)^8)&,2]/2;
v31=Root[1+8 #1+9 ((#1)^2)-7 ((#1)^3)+28 ((#1)^4)+6 ((#1)^5)-4 ((#1)^6)-((#1)^7)+((#1)^8)&,1]/2;
v32=Root[-1-5 #1+5 ((#1)^2)-4 ((#1)^3)+9 ((#1)^4)-5 ((#1)^5)+((#1)^6)-2 ((#1)^7)+((#1)^8)&,2]/2;
v33=-Root[-1+7 #1-13 ((#1)^2)-24 ((#1)^3)+4 ((#1)^4)+10 ((#1)^5)-3 ((#1)^7)+((#1)^8)&,1]/2;

(*  although equations can be solved explicitely, it's more efficient to express the solutions by Root[] objects *)
vect={{v11,v12,v13},{v21,v22,v23},{v31,v32,v33}};
Length[vertices=Join[Flatten[orbit[#,icoG]&/@vect,1],icosV]]//Timing

SimplifyNumericallyDistinct[Norm/@vertices]//Union//Timing

Graphics3D[{PointSize[Large],Point[vertices]},Boxed->False,Method->{"ShrinkWrap"->True}]

Length[edges=UnitEdges[vertices]]//Timing

g=Graph[Range[Length[vertices]],UndirectedEdge@@@edges,VertexCoordinates->vertices]

UnitDistanceGraphEmbeddingQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g,WorkingPrecision->∞]//Quiet//Timing

VertexChromaticNumber[g]//Timing//AbsoluteTiming

<<IGraphM`

IGChromaticNumber[g]//Timing//AbsoluteTiming

"VoronovNeopryatnayaDergachevGraph972"

Embeddings

GraphData["VoronovNeopryatnayaDergachevGraph972","StandardName"]

Default

GraphData["VoronovNeopryatnayaDergachevGraph972"]

All

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

Circular

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

Halin

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

LCF

GraphData["VoronovNeopryatnayaDergachevGraph972","LCF"]

GraphData["VoronovNeopryatnayaDergachevGraph972","LCFSignature"]

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

LCF compute

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

Tally[(lcf=LCF[GraphData["VoronovNeopryatnayaDergachevGraph972"],All])[[All,2]]]

gs=LCFGraph@@@DeleteCases[lcf,{_,1|2}]

UnitDistance

GraphData["VoronovNeopryatnayaDergachevGraph972","UnitDistance"]

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

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

Matchstick

GraphData["VoronovNeopryatnayaDergachevGraph972","Matchstick"]

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

MinimalCrossing

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

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

Default embedding

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

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

RecognizeGraph[g]

MinimalCrossing construction

CrossingNumber[GraphData["VoronovNeopryatnayaDergachevGraph972"],TimeConstraint->10]//AbsoluteTiming

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

g=RotateGraph[MinimalCrossingGraph[GraphData["VoronovNeopryatnayaDergachevGraph972"],"CrossingNumber"->-1]]

RecognizeGraph[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["VoronovNeopryatnayaDergachevGraph972","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["VoronovNeopryatnayaDergachevGraph972","Polyhedral"]

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

Construction

Code modified from:

https://github.com/vsvor/dist-graphs/

(* icosahedron symmetry group elements*)
f=(1+Sqrt[5])/2;
mirr={{1,0,0},{0,0,1},{0,1,0}};
icoGenerators={{{-1,0,0},{0,-1,0},{0,0,1}},{{0,0,1},{1,0,0},{0,1,0}},
mirr.(1/2 {{1,-f,1/f},{f,1/f,-1},{1/f,1,f}}).mirr,{{1,0,0},{0,-1,0},{0,0,1}}};

Length[icoG=makeGroup[icoGenerators]]//Timing

(*  vertex of the icosahedron  *)
v= {1/2,(Sqrt[5]+1)/4,0}/f;

(* using 8 points from the embedding of the 10-vertex unit distance graph we compute 8*120 vertices  *)

v11 = Root[-49-147 #1-71 ((#1)^2)+67 ((#1)^3)+129 ((#1)^4)+97 ((#1)^5)+42 ((#1)^6)+10 ((#1)^7)+((#1)^8)&,2]/2;
v12 = Root[-19+57 #1+206 ((#1)^2)+117 ((#1)^3)-11 ((#1)^4)-23 ((#1)^5)+((#1)^6)+2 ((#1)^7)+((#1)^8)&,1]/2;
v13 = Root[25+150 #1+315 ((#1)^2)+370 ((#1)^3)+284 ((#1)^4)+145 ((#1)^5)+49 ((#1)^6)+10 ((#1)^7)+((#1)^8)&,2]/2;
v21= Root[-49-147 #1-71 ((#1)^2)+67 ((#1)^3)+129 ((#1)^4)+97 ((#1)^5)+42 ((#1)^6)+10 ((#1)^7)+((#1)^8)&,1]/2;
v22= Root[-19+57 #1+206 ((#1)^2)+117 ((#1)^3)-11 ((#1)^4)-23 ((#1)^5)+((#1)^6)+2 ((#1)^7)+((#1)^8)&,2]/2;
v23=-Root[25+150 #1+315 ((#1)^2)+370 ((#1)^3)+284 ((#1)^4)+145 ((#1)^5)+49 ((#1)^6)+10 ((#1)^7)+((#1)^8)&,1]/2 ;
v31=Root[1+#1-16 ((#1)^2)-21 ((#1)^3)+34 ((#1)^4)+156 ((#1)^5)+234 ((#1)^6)+159 ((#1)^7)+41 ((#1)^8)&,1]/2 ;
v32= Root[-1-15 #1-55 ((#1)^2)-121 ((#1)^3)+269 ((#1)^4)+690 ((#1)^5)+616 ((#1)^6)+257 ((#1)^7)+41 ((#1)^8)&,1]/2;
v33= Root[-41-211 #1-231 ((#1)^2)-148 ((#1)^3)-13 ((#1)^4)+75 ((#1)^5)+223 ((#1)^6)+174 ((#1)^7)+41 ((#1)^8)&,1]/2;
v41 = Root[1+#1-16 ((#1)^2)-21 ((#1)^3)+34 ((#1)^4)+156 ((#1)^5)+234 ((#1)^6)+159 ((#1)^7)+41 ((#1)^8)&,2]/2;
v42 =- Root[-1-15 #1-55 ((#1)^2)-121 ((#1)^3)+269 ((#1)^4)+690 ((#1)^5)+616 ((#1)^6)+257 ((#1)^7)+41 ((#1)^8)&,2]/2;
v43 = -Root[-41-211 #1-231 ((#1)^2)-148 ((#1)^3)-13 ((#1)^4)+75 ((#1)^5)+223 ((#1)^6)+174 ((#1)^7)+41 ((#1)^8)&,2]/2;
v51= Root[-1+5 #1+10 ((#1)^2)+8 ((#1)^3)+69 ((#1)^4)+205 ((#1)^5)+269 ((#1)^6)+169 ((#1)^7)+41 ((#1)^8)&,2]/2;
v52=Root[1-13 #1+61 ((#1)^2)-138 ((#1)^3)+164 ((#1)^4)-118 ((#1)^5)+96 ((#1)^6)-93 ((#1)^7)+41 ((#1)^8)&,2]/2;
v53=Root[269-232 #1-669 ((#1)^2)+471 ((#1)^3)+642 ((#1)^4)-335 ((#1)^5)-258 ((#1)^6)+72 ((#1)^7)+41 ((#1)^8)&,2]/2;
v61=Root[-1+5 #1+10 ((#1)^2)+8 ((#1)^3)+69 ((#1)^4)+205 ((#1)^5)+269 ((#1)^6)+169 ((#1)^7)+41 ((#1)^8)&,1]/2;
v62=Root[1-13 #1+61 ((#1)^2)-138 ((#1)^3)+164 ((#1)^4)-118 ((#1)^5)+96 ((#1)^6)-93 ((#1)^7)+41 ((#1)^8)&,1]/2;
v63=Root[269+232 #1-669 ((#1)^2)-471 ((#1)^3)+642 ((#1)^4)+335 ((#1)^5)-258 ((#1)^6)-72 ((#1)^7)+41 ((#1)^8)&,2]/2;
v71 = Root[-1+4 #1-2 ((#1)^2)-12 ((#1)^3)-((#1)^4)+15 ((#1)^5)+15 ((#1)^6)+6 ((#1)^7)+((#1)^8)&,1]/2;
v72 = Root[-1+10 #1-5 ((#1)^2)+18 ((#1)^3)+19 ((#1)^4)-15 ((#1)^5)-((#1)^6)-((#1)^7)+((#1)^8)&,2]/2;
v73 = Root[1-14 #1+36 ((#1)^2)+29 ((#1)^3)+13 ((#1)^4)+17 ((#1)^5)+19 ((#1)^6)+7 ((#1)^7)+((#1)^8)&,1]/2;
v81=Root[-1-#1-2 ((#1)^2)+4 ((#1)^3)+14 ((#1)^4)+15 ((#1)^5)+13 ((#1)^6)+6 ((#1)^7)+((#1)^8)&,1]/2;
v82=(1/2) (1-(Sqrt[6-3 (Sqrt[5])+2 (Sqrt[-(37/2)+((17 (Sqrt[5]))/2)])]))/2;
v83=Root[-41-37 #1+108 ((#1)^2)+45 ((#1)^3)-42 ((#1)^4)-11 ((#1)^5)+4 ((#1)^6)+2 ((#1)^7)+((#1)^8)&,2]/2;

(*  although equations can be solved explicitely, it's more efficient to express the solutions by Root[] objects *)

vect={{v11,v12,v13},{v21,v22,v23},{v31,v32,v33},{v41,v42,v43},{v51,v52,v53},{v61,v62,v63},{v71,v72,v73},{v81,v82,v83}};
nVect=8;
nVer = 972;

Length[icosV=orbit[v,icoG]]

Length[vertices=Join[Flatten[orbit[#,icoG]&/@vect,1],icosV]]//Timing

SimplifyNumericallyDistinct[Norm/@vertices]//Union//Timing

ToRadicals[(NumericalApproximation[Root, (RowDefault["0.588", FEExpressionsNumericalApproximationElider]), Root[5-20 ((#1)^2)+16 ((#1)^4)&,3], ])]

Graphics3D[{PointSize[Large],Point[vertices]},Boxed->False,Method->{"ShrinkWrap"->True}]

Length[edges=UnitEdges[vertices]]//Timing

g=Graph[Range[Length[vertices]],UndirectedEdge@@@edges,VertexCoordinates->vertices]

UnitDistanceGraphEmbeddingQ[g]//Timing

UnitDistanceGraphEmbeddingQ[g,WorkingPrecision->∞]//Quiet//Timing

VertexChromaticNumber[g]//Timing//AbsoluteTiming

<<IGraphM`

IGChromaticNumber[g]//Timing//AbsoluteTiming

GraphData

GraphDataString

<<MathWorld`Graphs`

file=OpenAppend["~/vnd.m"]

"VoronovNeopryatnayaDergachevGraph372"

WriteString[file,GraphDataString[,
"StandardName"->"VoronovNeopryatnayaDergachevGraph372",
"Name"->"Voronov\[Hyphen]Neopryatnaya\[Hyphen]Dergachev graph 372",
"Embeddings"->{},
"ChromaticNumber"->5,
"Information"->"Voronov-Neopryatnaya-DergachevGraphs",
"Skip"->{"CliqueCoveringNumber","MinimumVertexCover","MinimumVertexCut"},
TimeConstraint->10]]

"VoronovNeopryatnayaDergachevGraph972"

WriteString[file,GraphDataString[,
"StandardName"->"VoronovNeopryatnayaDergachevGraph972",
"Name"->"Voronov\[Hyphen]Neopryatnaya\[Hyphen]Dergachev graph 972",
"Embeddings"->{},
"ChromaticNumber"->5,
"Information"->"Voronov-Neopryatnaya-DergachevGraphs",
"Skip"->{"CliqueCoveringNumber","MinimumVertexCover","MinimumVertexCut","Minors"},
TimeConstraint->10]]