Gosset Graph

Author

Eric W. Weisstein
October 30, 2023

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

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

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

Embeddings

<<MathWorld`Graphs`

"GossetGraph"

Names

GraphData["GossetGraph","StandardName"]

GraphData["GossetGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["GossetGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

DegenerateGraphEmbeddingTypes/@GraphData["GossetGraph","Graph","Degenerate"]

Perspective

GraphData["GossetGraph","Graph","Perspective"]//StyleGraphs

Perspective construction

GraphData["GossetGraph","Polyhedron"]

Bilateral

GraphData["GossetGraph","Graph","Bilateral"]//StyleGraphs

Circular

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

Planar

GraphData["GossetGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

(cn=CrossingNumber[GraphData["GossetGraph"],TimeConstraint->1])//AbsoluteTiming

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

(cn=CrossingNumber[GraphData["GossetGraph"],TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["GossetGraph"],TimeConstraint->3600])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData["GossetGraph"],"CrossingNumber"->cn])//PolyhedralGraphQ

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[g,"OuterFace"->#]&/@faces

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

Table[MinimalCrossingGraph[GraphData["GossetGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["GossetGraph","Circulant"]

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

Complement graph

GraphData["GossetGraph","ComplementGraph","Name"]

Line graph

GraphData["GossetGraph","Line"]

LineGraphQ[GraphData["GossetGraph"]]//Timing

RootGraph

Select[GraphData[All],GraphData[#,"LineGraph","Name"]=== "GossetGraph"&]

RootGraph[GraphData["GossetGraph"]]

Halin

GraphData["GossetGraph","Halin"]

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

Rigid

GraphData["GossetGraph","Rigid"]

GraphData["GossetGraph","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["GossetGraph","Flexible"]

GraphData["GossetGraph","Graph","Flexible"]//StyleGraphs

LCF

GraphData["GossetGraph","LCF"]

GraphData["GossetGraph","HamiltonianCycleCount"]

GraphData["GossetGraph","LCFSignature"]

GraphData["GossetGraph","LCFNotations"]

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

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

LCF compute random

Divisors[GraphData["GossetGraph","V"]]

FindRandomLCFNotation[GraphData["GossetGraph"],TimeConstraint->3600]//Timing//AbsoluteTiming

FindRandomLCFNotation[GraphData["GossetGraph"],TimeConstraint->5 3600]//Timing//AbsoluteTiming

FindRandomLCFNotation[GraphData["GossetGraph"],TimeConstraint->10 3600]//Timing//AbsoluteTiming

LCF compute 10^6

Tally[(lcf=LCF[GraphData["GossetGraph"],10^6])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

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

Length[gs]

LCF compute 10^7

Divisors[GraphData["GossetGraph","V"]]

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

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

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

Length[gs]

gs

LCF compute 5*^7

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

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

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

Length[gs]

LCF compute all

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

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

MaxMemoryUsed[]/10.^9 "GB"

Tally[(lcf=ReadProperty["LCFNotations",GraphNameToFileName["GossetGraph",".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

UnitDistance

GraphData["GossetGraph","UnitDistance"]

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

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData["GossetGraph","VertexList"],GraphData["GossetGraph","EdgeList"]],MaxIterations->500]

UnitDistanceEmbeddingRefine[Annotate[#,VertexCoordinates->N[GraphEmbedding[#]]],MaxIterations->500]&/@Complement@@(GraphData["GossetGraph","Graph",#]&/@{"All","UnitDistance"})

UnitDistance by FindUnitDistanceEmbedding

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

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

Matchstick

GraphData["GossetGraph","Matchstick"]

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

3D default

Graph3D[GraphData["GossetGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["GossetGraph","Polyhedral"]

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

Construction

Wikipedia

g=SVGToGraph[Import["http://upload.wikimedia.org/wikipedia/commons/2/24/E7_graph.svg","String"]]

Through[{VertexCount,EdgeCount}[g]]

GraphData["GossetGraph",{"V","M","Degrees"}]

VertexDegree[g]

Cases[EdgeList[g],1\[UndirectedEdge]_]

SetProperty[SetProperty[g,System`VertexLabels->Table[i->Placed[Style[i,15,Background->Yellow],Center],{i,56}]],System`VertexStyle->Red]

g=;

(There are 3 rings of 18 vertices, and two vertices coincide in the center of this projection. Edges also coincide with this projection.)

VertexCount[g]

EdgeCount[g]

VertexDegree[g]

Permutations of {-3, 1, 1, 1, 1, 1, -3, 1}

From Ed Pegg, Jr.
July 31, 2012

A classic definition of the vertices of the Gosset graph uses permutations of {-3,1,1,1,1,1,-3,1} and its negative. Here, they are arranged in a way that makes 3 sets of icosahedral vertices and a set of dodecahedral vertices.

V8 = {
{-1,-1,-1,3,-1,-1,-1,3},{-3,1,1,1,1,1,-3,1},{-1,3,-1,-1,-1,-1,-1,3},{-1,-1,-1,-1,-1,3,-1,3},{-3,1,1,1,-3,1,1,1},{-3,1,-3,1,1,1,1,1},{-1,3,-1,-1,-1,3,-1,-1},{1,1,-3,1,-3,1,1,1},{-1,-1,-1,3,-1,3,-1,-1},{-1,3,-1,3,-1,-1,-1,-1},{1,1,-3,1,1,1,-3,1},{1,1,1,1,-3,1,-3,1},

{-1,3,-1,-1,3,-1,-1,-1},{1,1,-3,1,1,-3,1,1},{-1,-1,-1,-1,3,3,-1,-1},{1,-3,-3,1,1,1,1,1},{3,-1,-1,-1,-1,-1,-1,3},{1,1,1,1,1,1,-3,-3},{-1,-1,-1,-1,-1,-1,3,3},{-3,1,1,1,1,1,1,-3},{-1,3,3,-1,-1,-1,-1,-1},{1,1,1,1,-3,-3,1,1},{-1,-1,3,-1,-1,3,-1,-1},{1,-3,1,1,-3,1,1,1},{1,1,1,-3,-3,1,1,1},{1,1,1,1,-3,1,1,-3},{-1,-1,-1,-1,3,-1,-1,3},{-1,-1,-1,3,3,-1,-1,-1},{3,-1,-1,-1,-1,3,-1,-1},{-1,3,-1,-1,-1,-1,3,-1},{1,-3,1,1,1,1,-3,1},{-3,1,1,1,1,-3,1,1},

{3,-1,-1,-1,3,-1,-1,-1},{-1,-1,-1,-1,3,-1,3,-1},{1,1,1,-3,1,-3,1,1},{1,1,1,1,1,-3,1,-3},{1,-3,1,-3,1,1,1,1},{1,-3,1,1,1,1,1,-3},{3,-1,3,-1,-1,-1,-1,-1},{-1,-1,3,-1,-1,-1,3,-1},{1,1,1,-3,1,1,1,-3},{3,-1,-1,-1,-1,-1,3,-1},{-1,-1,3,-1,3,-1,-1,-1},{1,-3,1,1,1,-3,1,1},

{1,1,1,-3,1,1,-3,1},{3,-1,-1,3,-1,-1,-1,-1},{-3,1,1,-3,1,1,1,1},{-1,-1,-1,3,-1,-1,3,-1},{3,3,-1,-1,-1,-1,-1,-1},{-1,-1,-1,-1,-1,3,3,-1},{1,1,1,1,1,-3,-3,1},{-3,-3,1,1,1,1,1,1},{1,1,-3,-3,1,1,1,1},{1,1,-3,1,1,1,1,-3},{-1,-1,3,-1,-1,-1,-1,3},{-1,-1,3,3,-1,-1,-1,-1}};

Here are 3D representations of these points. Again, these make 3 sets of icosahedral vertices and a set of dodecahedral vertices.

τ = GoldenRatio;
V3 = {
{-1,-τ,0},{-1,τ,0},{0,-1,-τ},{0,-1,τ},{0,1,-τ},{0,1,τ},{1,-τ,0},{1,τ,0},{-τ,0,-1},{-τ,0,1},{τ,0,-1},{τ,0,1},

{-2,-2,-2},{-2,-2,2},{-2,2,-2},{-2,2,2},{0,-2 τ,2-2 τ},{0,-2 τ,2 (-1+τ)},{0,2 τ,2-2 τ},{0,2 τ,2 (-1+τ)},{2,-2,-2},{2,-2,2},{2,2,-2},{2,2,2},{2-2 τ,0,-2 τ},{2-2 τ,0,2 τ},{2 (-1+τ),0,-2 τ},{2 (-1+τ),0,2 τ},{-2 τ,2-2 τ,0},{-2 τ,2 (-1+τ),0},{2 τ,2-2 τ,0},{2 τ,2 (-1+τ),0},

{-2,-2 τ,0},{-2,2 τ,0},{0,-2,-2 τ},{0,-2,2 τ},{0,2,-2 τ},{0,2,2 τ},{2,-2 τ,0},{2,2 τ,0},{-2 τ,0,-2},{-2 τ,0,2},{2 τ,0,-2},{2 τ,0,2},

{0,-2 τ,-2 (1+τ)},{0,-2 τ,2 (1+τ)},{0,2 τ,-2 (1+τ)},{0,2 τ,2 (1+τ)},{-2 τ,-2 (1+τ),0},{-2 τ,2 (1+τ),0},{2 τ,-2 (1+τ),0},{2 τ,2 (1+τ),0},{-2 (1+τ),0,-2 τ},{-2 (1+τ),0,2 τ},{2 (1+τ),0,-2 τ},{2 (1+τ),0,2 τ}};

It has 756 edges.

Length[edges = Drop[Union[Flatten[Table[If[EuclideanDistance[V8[[a]],V8[[b]]]^2==32, {a,b}],{a,1,55},{b,a+1,56}],1]],1]]

Through[{V,M}[g=Combinatorica`Graph[List/@edges,List/@CircularEmbedding[56]]]]

RecognizeGraph[g]

And a picture in 3D.

Graphics3D[{
Red,Sphere[#,.15]&/@Take[V3,{1,12}],
Green,Sphere[#,.15]&/@Take[V3,{13,32}],
Yellow,Sphere[#,.15]&/@Take[V3,{33,44}],
Cyan,Sphere[#,.15]&/@Take[V3,{45,56}],
Black, Line[V3[[#]]]&/@edges},
SphericalRegion-> True, Boxed-> False, ViewAngle-> Pi/8]

From E8 lattice

https://cp4space.hatsya.com/2013/09/12/leech-lattice/

If we take the convex hull of the 240 shortest vectors in the E8 lattice, we obtain the beautiful semiregular Gosset E8 polytope.

LatticeData["E8","Basis"]

DVectors[n_]:=Module[{e=IdentityMatrix[n],i,j,s1,s2},
Union[Flatten[Table[If[i==j,Sequence@@{},s1 e[[i]]+s2 e[[j]]],{s1,-1,1,2},{i,n},{s2,-1,1,2},{j,n}],3]]
]

DVectors[3]

Length[E8=Join[DVectors[8],Select[Flatten[Outer[List,Sequence@@Table[{-1,1},{8}]],7],EvenQ[Count[#,1]]&]/2]]

E8.E8 = 1

E8Graph=MakeGraph[E8,#1.#2==1&,Type->Undirected]

RegularQ[E8Graph]

RecognizeGraph[E8Graph]

RegularParameters[E8Graph]

IntegerSpectrum[E8Graph]//SpectrumForm//TraditionalForm

E8 lines perp

Length[lines=Union[First[Sort[{-#,#}]]&/@E8]]

sr120perp=MakeGraph[lines,#1.#2==0&,Type->Undirected]

RecognizeGraph[sr120perp]

RegularParameters[sr120perp]

IntegerSpectrum[sr120perp]//SpectrumForm//TraditionalForm

E8 lines not perp

sr120notperp=MakeGraph[lines,#1=!=#2&&#1.#2!=0&,Type->Undirected]

RecognizeGraph[sr120notperp]

RegularParameters[sr120notperp]

IntegerSpectrum[sr120notperp]//SpectrumForm//TraditionalForm

Local E8 lines not perp

v=Neighborhood[sr120notperp,1,1]

sr=DeleteVertices[sr120notperp,v]

RecognizeGraph[sr]

RegularParameters[sr]

RecognizeGraph[sr]

Gosset

(E7=Select[E8,Total[#]==0&])//Length

(e756=Select[E7,IntegerQ[First[#]]&])//Length

(e770=Select[E7,!IntegerQ[First[#]]&])//Length

Tally[Flatten[Outer[(#1-#2).(#1-#2)&,e756,e756,1]]]

g=MakeGraph[e756,(#1-#2).(#1-#2)==2&,Type->Undirected]

RegularQ[g]

Degrees[g]//Union

g=MakeGraph[e756,(#1-#2).(#1-#2)==4&,Type->Undirected]

ConnectedQ[g]

RegularQ[g]

Degrees[g]//Union

g=MakeGraph[e756,(#1-#2).(#1-#2)==8&,Type->Undirected]

RegularQ[g]

Degrees[g]//Union

EVectors[n_]:=Module[{e=IdentityMatrix[n],i,j},
Join[
Union[Flatten[Table[If[i==j,Sequence@@{},e[[i]]+ e[[j]]],{i,n},{j,n}],1]],
Union[Flatten[Table[If[i==j,Sequence@@{},Table[1,{8}]/2-e[[i]]- e[[j]]],{i,n},{j,n}],1]]
]
]

EVectors[8]

Length[%]

Select[E8,#.Table[1,{8}]/2==1&]==EVectors[8]

GossetGraph=MakeGraph[EVectors[8],#1.#2==1&,Type->Undirected]

RegularQ[GossetGraph]

IntegerSpectrum[GossetGraph]//SpectrumForm//TraditionalForm

Union[Degrees[GossetGraph]]

GraphPlot[GossetGraph,Method->None]

distanceregular.org

g=DistanceRegularGraph["http://www.distanceregular.org/graphdata/gosset.am"]

RecognizeGraph[g]

VertexCount[g]

GraphDiameter[g]//Timing

RegularParameters[g]//Timing

DistanceRegularGraphQ[g]//Timing

IntersectionArray[g]//Timing

IntegerSpectrum[g]//SpectrumForm

GroupOrder[GraphAutomorphismGroup[g]]

HamiltonianGraphQ[g]

GraphData

file=OpenWrite["sr.m"]

WriteString[file,GraphDataString[sr,
"Name"->"(63,32,16,16)-strongly regular graph",
"StandardName"->{"StronglyRegular",{{63,32,16,16},1}},
"Information"->"StronglyRegularGraph",
"Vertices"->None,
"Skip"->{"Perfect"},
TimeConstraint->60,
Debug->True
]]

WriteString[file,GraphDataString[sr120notperp,
"Name"->"(120,56,28,24)-strongly regular graph",
"StandardName"->{"StronglyRegular",{{120,56,28,24},1}},
"Information"->"StronglyRegularGraph",
"Vertices"->None,
"Skip"->{"Perfect"},
TimeConstraint->60,
Debug->True
]]

WriteString[file,GraphDataString[sr120perp,
"Name"->"(120,63,30,36)-strongly regular graph",
"StandardName"->{"StronglyRegular",{{120,63,30,36},1}},
"Information"->"StronglyRegularGraph",
"Vertices"->None,
"Skip"->{"Perfect"},
TimeConstraint->60,
Debug->True
]]

WriteString[file,GraphDataString[GossetGraph,
"Name"->"Gosset graph",
"StandardName"->"GossetGraph",
"Information"->"GossetGraph",
"Vertices"->None,
"Skip"->{"Perfect"},
TimeConstraint->60,
Debug->True
]]

Close[file]