24-Cell

Author

Eric W. Weisstein
June 12, 2019

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

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

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

Additional Authors

Projection and animation from Russell Towle

Partition into 3 hypercubes by Ed Pegg, Jr.
Feb. 15, 2007

Construction

Vertices

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

Cell24Construction:=Module[
{
vs={Permutations[{#1,#2,0,0}]&@@@pm[2]}
},
Union[Flatten[#,1]]&/@vs
]

v=Union@@Cell24Construction

VertexCount

Length/@Cell24Construction

Length[v]

EdgeLengths

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

N[%]

Circumradius

Max[d]

Edges

e=Select[Subsets[Range[24],{2}],EuclideanDistance@@v[[#]]==(Sqrt[2])&]

Length[e]

Faces

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

Length[faces]

Cells

The boundary of the 24-cell is composed of 24 octahedral cells with six meeting at each vertex, and three at each edge.

Length[faces]

cells=Select[Subsets[faces,{8}],Tally[Flatten[#]][[All,2]]==ConstantArray[4,6]&]/.Thread[faces->Range[Length[faces]]]

Binomial[96,8]

sub=Developer`ToPackedArray[Subsets[Range[Length[faces]],{8}]];

cells=Select[sub,Tally[Flatten[faces[[#]]]][[All,2]]==ConstantArray[4,6]&]

Content

ConvexHullMesh[v]

RegionMeasure[%]

Graph

RecognizeGraph[Graph[UndirectedEdge@@@e]]

NetCount

6((2^19)5688888889+347)//N//ScientificForm

SymmetryGroup

https://en.wikipedia.org/wiki/24-cell #Symmetries,_root _systems,_and _tessellations

The full symmetry group of the 24-cell is the Weyl group of F4, which is generated by reflections through the hyperplanes orthogonal to the F4 roots. This is a solvable group of order 1152. The rotational symmetry group of the 24-cell is of order 576.

GraphData["TwentyFourCellGraph","AutomorphismCount"]

FiniteGroupData[1152]

Skeleton

Embeddings

GraphicsGrid[Partition[GraphData["TwentyFourCellGraph","Graph","All"]//StyleGraphs,UpTo[3]],ImageSize->400]

GraphData["TwentyFourCellGraph","LCFNotations"]

2-D Embeddings

GraphData["TwentyFourCellGraph","Image2D"]

3-D Embedding

Show[GraphData["TwentyFourCellGraph","Graph","3D"],Boxed->False]

AutomorphismCount

GraphData["TwentyFourCellGraph","AutomorphismCount"]

GraphAutomorphismGroup[GraphData["TwentyFourCellGraph"]]

GroupOrder[%]

CyclePolynomial

A167983

GraphData["TwentyFourCellGraph","CyclePolynomial"][x]

Rest@CoefficientList[%,x]

ListPlot[%,Filling->Automatic]

Diameter

GraphData["TwentyFourCellGraph","Diameter"]

GraphDiameter[GraphData["TwentyFourCellGraph"]]

PathPolynomial

GraphData["TwentyFourCellGraph","PathPolynomial"]

%[[2,All,2]]

2%

Skeleton Construction

ShowLabeledGraph[g=
AddEdges[ChangeVertices[
GraphUnion[
CirculantGraph[12,{1,2}],
CirculantGraph[12,{2,5}]
],
Join[
Through[{Cos,Sin}[2#Pi/12]]&/@Range[0,11],
Through[{Cos,Sin}[(#+1/2)2Pi/12]]&/@Range[0,11].52
]],
Join[
Table[{n,n+11},{n,2,12}],
Table[{n,n+12},{n,12}],
{{1,24},{1,15},{1,22},{2,16},{2,23},{3,17},{3,24},{4,13},{4,18},{5,14},{5,19},{6,15},{6,20},{7,16},{7,21},{8,17},{8,22},{9,18},{9,23},{10,19},{10,24},{11,13},{11,20},{12,14},{12,21}}]
],VertexStyle->Disk[.02]]

l1={{1,15},{1,22},{2,16},{2,23},{3,17},{3,24},{4,13},{4,18},{5,14},{5,19},{6,15},{6,20},{7,16},{7,21},{8,17},{8,22},{9,18},{9,23},{10,19},{10,24},{11,13},{11,20},{12,14},{12,21}};

l2=Table[{n,n+14},{n,10}]

Complement[l1,l2]

l3=Table[{n,n+9},{n,4,12}]

Complement[l1,l2,l3]

l4=Table[{n,n+21},{n,3}]

DegreeSequence[g]

IsomorphicQ[g,Cell24Graph]//Timing

3-Hypercube embedding

g1=Show[kk=Graphics[],AspectRatio->Automatic];

g2=ShowGraph[g=LinesToGraph[kk,20]]

Show[GraphicsArray[{g1,g2}],ImageSize->500]

ToCommonEdges[g,CombinatoricaGraph["TwentyFourCellGraph"]]

Graph Properties

Through[{V,M,Girth,Diameter,RegularQ,RegularParameters}[Cell24Graph]]

DegreeSequence[Cell24Graph]

Spectrum

Spectrum[Cell24Graph]//SpectrumForm

{First[#],Length[#]}&/@Split[Distances[Cell24Graph,1]]

Last/@%

Figure

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

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

gr=FromEdges[vi343,c];
{v,e}={V[gr],M[gr]};
Print[{v,e}];
ShowGraph[gr]

Properties

(#->GraphData["TwentyFourCellGraph",#])&/@GraphData["Properties"]//ColumnForm

Animation

(* 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[Norm[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[Norm[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[vi343,{0,Pi,Pi/15},1,2,ViewPoint->{0,0,2}]

WriteLiveForm["cell24.m",movie,AnimatioDirection->ForwardBackward]