600-Cell

Author

Eric W. Weisstein
June 12, 2019

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polytopes/600-Cell.nb.

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

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

Additional Authors

Projection and animation from Russell Towle
Ed Pegg, Jr.

Sources

[Submitted on 26 Sep 2023]
The Icosidodecahedron
John C. Baez

https://arxiv.org/abs/2309.15774

Construction

Vertices

EvenPermutationQ[p_]:=Signature[p]==-1
EvenPermutations[l_List]:=Module[{p=Permutations[Range[Length[l]]]},Permutations[l][[Flatten[Position[p,_?EvenPermutationQ,1,Heads->False]]]]
]

pm[n_]:=Flatten[Outer[List,Sequence@@Table[{-1,1},{n}]],n-1]

Cell600Construction:=With[{s=(Sqrt[5]),r=GoldenRatio},
Module[{
vs={
EvenPermutations[{r#1,#2,#3/r,0}]&@@@pm[3],
Permutations[{2#1,0,0,0}]&@@@pm[1],
{pm[4]}
}
},
Union[Flatten[#,1]]&/@vs
]
]

Length/@Cell600Construction

v=GoldenRatio/2Join@@Cell600Construction

VertexCount

Length[v]

Edges

Length[e=Select[Subsets[Range[Length[v]],{2}],EuclideanDistance@@v[[#]]==2/GoldenRatio&]]

Length[e=Select[Subsets[Range[Length[v]],{2}],N[EuclideanDistance@@v[[#]],20]==1&]]

e

EdgeLengths

d=Union[EuclideanDistance@@v[[#]]&/@e]//FullSimplify//FunctionExpand//FullSimplify//Union

Circumradius

Max[FullSimplify[Norm/@v]]

Content

ConvexHullMesh[v]

RegionMeasure[%]

Faces

faces=Sort[FindCycle[Graph[Range[120],UndirectedEdge@@@e],{3},All][[All,All,1]]]

Length[faces]

Cells

Length[v]

Vertices adjacent to i for each i

indexed=Table[{i,Flatten@DeleteCases[Select[e,!FreeQ[#,i]&],i,{2}]},{i,120}]

Pick the 3-subsets of adjacenct vertices such that all correspond to edges:

data={#[[1]],Select[Subsets[#[[2]],{3}],Length[Intersection[Sort/@Subsets[#,{2}],e]]==3&]}&/@indexed

Add back i, sort, and union to get the tetrahedral cells:

Union[Sort/@Flatten[Function[{i,l},Prepend[#,i]&/@l]@@@data,1]]

Length[%]

Check they're all uniform distance from each other

EuclideanDistance@@@Subsets[v[[{1,2,49,81}]],{2}]//FunctionExpand//FullSimplify//Union

Graph

RecognizeGraph[g=Graph[Range[Length[v]],UndirectedEdge@@@e]]

NetCount

2^188 3^102 5^20 7^36 11^48 23^48 29^30//N//ScientificForm

SymmetryGroup

https://en.wikipedia.org/wiki/600-cell #Coordinates

The full symmetry group of the 600-cell is the Weyl group of H4. This is a group of order 14400. It consists of 7200 rotations and 7200 rotation-reflections. The rotations form an invariant subgroup of the full symmetry group. The rotational symmetry group was described by S.L. van Oss (1899); see References.

GraphData["SixHundredCellGraph","AutomorphismCount"]

FiniteGroupData[14400]

Embeddings

Image

GraphicsRow[GraphData["SixHundredCellGraph","Images"]/.AbsolutePointSize[_]:>PointSize[.007],Spacings->-50,ImageSize->400]

Scraping

Embeddings from http://en.wikipedia.org/wiki/600-cell

SVGToGraph[svg_,Method->"Wikipedia"]:=Module[{
v=Cases[svg,XMLElement["circle",x__,{}]:>ToExpression[{"cx","cy"}/.x],{1,Infinity}],e=Cases[svg,XMLElement["line",x__,{}]:>ToExpression[{{"x1","y1"},{"x2","y2"}}/.x],{1,Infinity}],
mult=10^2
},
Combinatorica`Graph[List/@(Round[mult e]/mult/.Thread[Round[mult v]/mult->Range[Length[v]]]),List/@v]
]

(g1=SVGToGraph[Import["http://upload.wikimedia.org/wikipedia/commons/f/f4/600-cell_graph_H4.svg","XML"],Method->"Wikipedia"])//RecognizeGraph

(g2=SVGToGraph[Import["http://upload.wikimedia.org/wikipedia/commons/f/f8/600-cell_t0_p20.svg","XML"],Method->"Wikipedia"])//RecognizeGraph

(g3=SVGToGraph[Import["http://upload.wikimedia.org/wikipedia/commons/f/fd/600-cell_t0_F4.svg","XML"],Method->"Wikipedia"])//RecognizeGraph

ToCommonEdges[#,Combinatorica`Graph["SixHundredCellGraph"]]&/@{g1,g2,g3}/500

GetGraphData["HundredTwentyCellGraph","File",#]&/@{"8.0","8.1"}

Misc

GraphData["600CellGraph","Image2D"]

GraphData["600CellGraph","Image3D"]

Van Oss Projection

The often published version is the Van Oss Projection of the 600-cell that dates to 1901, and which was used as the frontispiece to Regular Polytopes.   It's the Pi/15 shadow of a 3D 600-cell model.                                            
                                                                                                              
http://homepages.wmich.edu/~drichter/vanoss.htm                                                               
http://www.ams.org/notices/200101/fea-stillwell.pdf   (p. 22)                                                 
http://en.wikipedia.org/wiki/Image:600-cell_petrie_polygon.svg                                                
http://www.math.lsa.umich.edu/~jrs/coxplane2.html                                                             
http://mathworld.wolfram.com/600-Cell.html

{a,b,c,d} = {12,25,30,37};  (*radius of a ring of nodes*)

cell600 ={
{{a,a},{2,8}},{{a,a},{2,18}},{{a,a},{2,24}},{{a,b},{2,7}},{{a,b},{2,13}},{{a,b},{2,51}},{{a,b},{2,57}},{{a,c},{4,1}},{{a,c},{4,7}},{{b,b},{1,7}},{{b,c},{1,3}},{{b,c},{1,9}},{{b,c},{1,53}},{{b,c},{1,59}},{{b,d},{1,4}},{{b,d},{1,58}},{{c,c},{1,7}},{{c,d},{1,2}},{{c,d},{1,6}},{{c,d},{1,56}},{{c,d},{1,60}},{{d,d},{2,4}},{{d,d},{2,6}},{{d,d},{2,8}}};

With[{lines =Transpose/@Flatten[Table[Mod[cell600+Table[{{0,0},{n,n}},{24}],60,1],{n,2,60,2}],1]},Graphics[Table[Line[#[[1]]{Cos[Pi #[[2]]/30],Sin[Pi#[[2]]/30]}&/@lines[[k]]],{k,1,720}]]]

FastIsomorphicQ[Graph["SixHundredCellGraph"],g=LinesToGraph[%,1]]

GraphPlot[g,Method->None]

ToCommonEdges[g,Graph["600CellGraph"]]

GetGraphData["SixHundredCellGraph","File"]

Shadow Cast of the 600 Cell

by Ed Pegg Jr
based on Coxeter's Regular Polytopes
based on Russell Towle's Regular Polytopes program:  http://library.wolfram.com/infocenter/MathSource/593/.

First, set up all the vertices.  When complete, vii335 will contain the 120 4-D vertices.

{a,b,c,d}=Table[Root[1-15 ((#1)^2)+60 ((#1)^4)-90 ((#1)^6)+45 ((#1)^8)&,n],{n,8,5,-1}];
CC[k_]:=RootReduce[ToRadicals[Cos[k Pi/30]]];
SS[k_]:=RootReduce[ToRadicals[Sin[k Pi/30]]];

vii335=
Flatten[Map[RootReduce[Simplify[#]]&,Table[
{{a CC[2 (-1+k)],a SS[2 (-1+k)],d CC[22 (-1+k)],d SS[22 (-1+k)]},{b CC[-1+2 k],b SS[-1+2 k],c CC[-11+22 k],c SS[-11+22 k]},{c CC[-1+2 k],c SS[-1+2 k],-b CC[-11+22 k],-b SS[-11+22 k]},{d CC[2 (-1+k)],d SS[2 (-1+k)],-a CC[22 (-1+k)],-a SS[22 (-1+k)]}},
{k,1,30}],{2}],1];

All are at distance 1 from the origin.

Union[N[Norm/@vii335]]

Some rounding hackery to calculate the 720 edges.  With these, we can get a 2-D projection.

edges=Union[Sort/@Position[Round[100000Table[
N[Norm[vii335[[a]]-vii335[[b]]]],{a,1,120},{b,1,120}]],61803]];

Graphics[{Line/@Map[Take[vii335[[#]],2]&,edges,{2}],Red,AbsolutePointSize[3],Point[Take[#,2]]&/@vii335}]

Here's the shadow projection again, this time in 3D.

Graphics3D[{Line/@Map[Take[vii335[[#]],3]&,edges,{2}],Red,AbsolutePointSize[5],Point[Take[#,3]]&/@vii335},Boxed-> False,SphericalRegion-> True,ViewPoint-> {0,0,60},ViewAngle->1°]

quaternion 120 group

Quaternion multiplication can be checked.

Cell600 =Module[{a,b,c,d,e,f,g,h,i},{{e,c,c,c},{a,c,c,c},{b,c,f,g},{b,c,f,h},{b,c,i,g},{b,c,i,h},{b,g,c,f},{b,g,c,i},{b,h,c,f},{b,h,c,i},{b,f,g,c},{b,f,h,c},{b,i,g,c},{b,i,h,c},{b,b,b,b},{b,b,b,d},{b,b,d,b},{b,b,d,d},{b,d,b,b},{b,d,b,d},{b,d,d,b},{b,d,d,d},{c,b,g,f},{c,b,g,i},{c,b,h,f},{c,b,h,i},{c,d,g,f},{c,d,g,i},{c,d,h,f},{c,d,h,i},{c,g,f,b},{c,g,f,d},{c,g,i,b},{c,g,i,d},{c,h,f,b},{c,h,f,d},{c,h,i,b},{c,h,i,d},{c,f,b,g},{c,f,b,h},{c,f,d,g},{c,f,d,h},{c,i,b,g},{c,i,b,h},{c,i,d,g},{c,i,d,h},{c,a,c,c},{c,c,a,c},{c,c,c,a},{c,c,c,e},{c,c,e,c},{c,e,c,c},{h,b,f,c},{h,b,i,c},{h,c,b,f},{h,c,b,i},{h,c,d,f},{h,c,d,i},{h,d,f,c},{h,d,i,c},{h,f,c,b},{h,f,c,d},{h,i,c,b},{h,i,c,d},{f,b,c,g},{f,b,c,h},{f,c,g,b},{f,c,g,d},{f,c,h,b},{f,c,h,d},{f,d,c,g},{f,d,c,h},{f,g,b,c},{f,g,d,c},{f,h,b,c},{f,h,d,c},{d,c,f,g},{d,c,f,h},{d,c,i,g},{d,c,i,h},{d,g,c,f},{d,g,c,i},{d,h,c,f},{d,h,c,i},{d,f,g,c},{d,f,h,c},{d,i,g,c},{d,i,h,c},{d,b,b,b},{d,b,b,d},{d,b,d,b},{d,b,d,d},{d,d,b,b},{d,d,b,d},{d,d,d,b},{d,d,d,d},{g,b,f,c},{g,b,i,c},{g,c,b,f},{g,c,b,i},{g,c,d,f},{g,c,d,i},{g,d,f,c},{g,d,i,c},{g,f,c,b},{g,f,c,d},{g,i,c,b},{g,i,c,d},{i,b,c,g},{i,b,c,h},{i,c,g,b},{i,c,g,d},{i,c,h,b},{i,c,h,d},{i,d,c,g},{i,d,c,h},{i,g,b,c},{i,g,d,c},{i,h,b,c},{i,h,d,c}}/.{a->-1,b->-(1/2),c->0,d->(1/2),e->1,f->(1/4) (-1-(Sqrt[5])),g->(1/4) (1-(Sqrt[5])),h->(1/4) (-1+(Sqrt[5])),i->(1/4) (1+(Sqrt[5]))}];

mult[{a1_,b1_,c1_,d1_},{a2_,b2_,c2_,d2_}]:=RootReduce[{a1 a2−b1 b2−c1 c2−d1 d2,a1 b2+b1 a2+c1 d2−d1 c2,a1 c2−b1 d2+c1 a2+d1 b2,a1 d2+b1 c2−c1 b2+d1 a2}];

quat120group =1+Reverse[[[1,1]]];

Take[quat120group,3] ==  Table[Position[Cell600,mult[Cell600[[m]],Cell600[[n]]]][[1,1]],{n,1,3},{m,1,120}]

Manipulate

Manipulate[
With[{cell600 = {
{{a,a},{2,8}},{{a,a},{2,18}},{{a,a},{2,24}},{{a,b},{2,7}},{{a,b},{2,13}},{{a,b},{2,51}},{{a,b},{2,57}},{{a,c},{4,1}},{{a,c},{4,7}},{{b,b},{1,7}},{{b,c},{1,3}},{{b,c},{1,9}},{{b,c},{1,53}},{{b,c},{1,59}},{{b,d},{1,4}},{{b,d},{1,58}},{{c,c},{1,7}},{{c,d},{1,2}},{{c,d},{1,6}},{{c,d},{1,56}},{{c,d},{1,60}},{{d,d},{2,4}},{{d,d},{2,6}},{{d,d},{2,8}}}},
With[{lines =Transpose/@Flatten[Table[Mod[cell600+Table[{{0,0},{n,n}},{24}],60,1],{n,2,60,2}],1]},Graphics[Table[Line[#[[1]]{Cos[Pi #[[2]]/30],Sin[Pi#[[2]]/30]}&/@lines[[k]]],{k,1,720}]]]],
{{a,12},1,60},{{b,25},1,60},{{c,30},1,60},{{d,37},1,60}]

Properties

AutomorphismCount

GraphData["600CellGraph","AutomorphismCount"]

CyclePolynomial

A167985

GraphData["600CellGraph","CyclePolynomial"]

PathPolynomial

GraphData["600CellGraph","PathPolynomial"]

Spectrum

GraphData["600CellGraph","Spectrum"]//SpectrumForm//TraditionalForm

Graph Distances

{First[#],Length[#]}&/@Split[Distances[Graph["600CellGraph"],1]]

Last/@%

Union[N[Norm/@(Subtract@@@Subsets[Cell600,{2}]),20],
SameTest->(Abs[N[#1-#2,20]]<.0001&)]//Length//Timing

LCF

"LCF"/.GetGraphData["600CellGraph","NotationRules"]

GetGraphData["600CellGraph","HamiltonianCycles"]

HamiltonianCycles[Graph["600CellGraph"],1]//Timing

Tally[Last/@(lcf=LCF[GraphData["600CellGraph","EdgeIndices"],hc=Table[FindHamiltonianCycle[Graph["600CellGraph"],"RandomSeed"->i],{i,1000}],All])]//Timing

Tally[Last/@(lcf=LCF[GraphData["600CellGraph","EdgeIndices"],hc=Table[FindHamiltonianCycle[Graph["600CellGraph"],"RandomSeed"->i],{i,1001,10^4}],All])]//Timing

Tally[Last/@(lcf=LCF[GraphData["600CellGraph","EdgeIndices"],hc=Table[FindHamiltonianCycle[Graph["600CellGraph"],"RandomSeed"->i],{i,1+10^4,10^5}],All])]//Timing

Minimum Vertex Coloring

coloring={1,2,3,1,4,1,1,2,1,5,2,1,1,3,3,2,2,3,3,1,2,1,5,5,5,5,1,2,4,2,4,1,1,4,2,4,1,3,2,1,2,1,1,4,1,2,5,1,3,2,3,4,2,4,3,5,2,4,5,5,5,3,4,2,4,3,2,3,5,5,4,2,3,2,2,3,5,5,3,4,4,4,5,2,4,3,5,5,3,2,2,3,2,5,4,4,1,3,4,5,5,4,3,1,5,5,1,3,4,1,4,3,3,4,1,4,3,1,5,5};

ColoringQ[Graph["SixHundredCellGraph"],coloring]

SetProperty[GraphData["SixHundredCellGraph"],System`VertexStyle->MapIndexed[#2[[1]]->{Red,Orange,Yellow,Green,Blue}[[#]]&,coloring]]

Projection

spc={{1,2,3},{1,2,4},{1,3,4},{2,3,4}};

d=Union[ Map[N[Norm[First@Cell600-#]]&, Rest@Cell600],
SameTest->(Chop[#1-#2]==0&)];
v = (rota4[#1, Pi*11/15, Pi/15] & ) /@ Cell600;
c=Table[
a=Drop[v,i-1];
{First@a,#}& /@ Select[Rest@a, N[Norm[First@a-#]]<N[d[[2]]]&],
{i,Length[v]}];
v1=Map[#[[ spc[[2]] ]]&, v];
g=Map[#[[ spc[[2]] ]]&, Flatten[c,1], {-2} ];
Show[Graphics3D[{Line /@ Union[g],PointSize[.02],Point/@v1} ],
Boxed->False,
ViewPoint->{0,0,200}];

gr=FromEdges[Cell600,c];
ShowGraph[gr]

Animation

FromEdges[v_List,e_List]:=Module[{i},
FromUnorderedPairs[Flatten[e,1]/.Thread[Table[v[[i]]->i,{i,Length[v]}]]]
]

(* Animation *)
(* r= which 3-space:1(w=0),2(z=0),3(y=0),4(x=0)*)
(* t= PlotRange*)

PolytopeMovie[vertices_List,ang_List:{0,Pi,Pi/30},r_:1,t_:2,opts___]:=Module[{v,d,c,a,v1,g},
Table[v=(rota4[#1,i,i]&)/@vertices;
d=Union[(N[mag[v[[1]]-#1]]&)/@Rest[v],SameTest->(Chop[#1-#2]==0&)];
c=Table[a=Drop[v,i-1]; ({First[a],#1}&)/@Select[Rest[a],Chop[N[mag[First[a]-#1]]-d[[1]]]==0&],{i,Length[v]}];
v1=(#1[[spc[[r]]]]&)/@v;
g=Map[#1[[spc[[r]]]]&,Flatten[c,1],{-2}];
Show[Graphics3D[{Line/@Union[g],PointSize[0.02],Point/@v1}],Boxed->False,PlotRange->{{-t,t},{-t,t},{-t,t}},opts],{i,ang[[1]],ang[[2]]-ang[[3]],ang[[3]]}]
]

movie=PolytopeMovie[v335,{0,Pi/2,Pi/30},1,2,ViewPoint->{0,-1,2}];

WriteLiveAnimationForm["cell600.m",movie,AnimationDirection->ForwardBackward]

Export[gifs<>"cell600.gif",movie,
"GIF",ImageSize->200,AnimationDirection->ForwardBackward]