16-Cell

Author

Eric W. Weisstein
June 12, 2019

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

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

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

Construction

As +/-1 tuples

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

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

v=Join@@Cell16Construction

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

As a cross polytope

(* section 13.4 of Coxeter's Regular Polytopes *)
CrossPolytopeCoordinates[n_Integer?Positive]:=Module[{a,r,k},a=Table[Flatten[Table[Through[{Cos,Sin}[(2 r-1) Pi k/n]],{r,Floor[n/2]}]],{k,2 n}];
If[OddQ[n],Table[Join[a[[k]],{(-1)^k/Sqrt[2]}],{k,2 n}],(*Else*)a]/Sqrt[n]]

v=CrossPolytopeCoordinates[4]

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

Length[e]

RecognizeGraph@System`Graph[Range[8],UndirectedEdge@@@e]

Show[System`Graph[Range[8],UndirectedEdge@@@e,VertexCoordinates->v[[All,#]]],PlotLabel->#]&/@Subsets[Range[4],{2}]

VertexCount

Length/@Cell16Construction

Length[v]

Circumradius

Max[FullSimplify[Norm/@v]]

Content

ConvexHullMesh[v]

RegionMeasure[%]

Wikipedia inequality

https://en.wikipedia.org/wiki/Cross-polytope

{x∈(ℝ^n):(Norm2[x, 1])≤1}

Integrate[Boole[Norm[{x,y},1]≤1],{x,y}∈FullRegion[2]]//Timing

(1/((((Sqrt[2])))^3))Integrate[Boole[Norm[{x,y,z},1]≤1],{x,y,z}∈FullRegion[3]]//Timing

Norm[{x,y,z,w},1]

(1/((((Sqrt[2])))^4))Integrate[Boole[Norm[{x,y,z,w},1]≤1],{x,y,z,w}∈FullRegion[4]]//Timing

Octahedron/line segment

{1,RegionMeasure[Octahedron[]]}

Wikipedia formula

https://en.wikipedia.org/wiki/Cross-polytope #Higher _dimensions

The volume of the n-dimensional cross-polytope is (2^n)/n!

Table[((2^n)/((2^(n/2))n!)),{n,4}]

Edges

EuclideanDistance@@@Subsets[Range[Length[v]],{2}]//Union

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

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

e

Faces

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

Length[%]

Cells

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

Length[%]

Distances

Union[N[Norm/@(Subtract@@@Subsets[Cell16,{2}])]]//Length

Graph

RecognizeGraph[Graph[UndirectedEdge@@@e]]

NetCount

(2^5)((2^7)(3^3)+1+(3^2))

Graphics

Projection and animation from Russell Towle

Figure

line[l_List]:=Line[Join[l,{l[[1]]}]]

Show[Graphics[line[Orthoplex[2]]],AspectRatio->Automatic]

First@Union[Map[N[mag[#]]&,v334]](*circumradius*)

d=Union[ Map[N[mag[First@v334-#]]&, Rest@v334],
SameTest->(Chop[#1-#2]==0&)];
c=Table[
a=Drop[v334,i-1];
{First@a,#}& /@ Select[Rest@a, N[mag[First@a-#]]<N[d[[2]]]&],
{i,Length[v334]}];
v=Map[#[[ spc[[1]] ]]&, v334];
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[Orthoplex[4],c];
ShowGraph[gr]

{v,e}={V[gr],M[gr]}

deg=2;
k=KSubsets[Range[v-1],deg];
Print[{Binomial[v-1,deg],Length[k]}];
Position[IsomorphicQ[CirculantGraph[v,#],gr]&/@k,True]//Flatten

deg=3;
k=KSubsets[Range[v-1],deg];
Print[{Binomial[v-1,deg],Length[k]}];
Position[IsomorphicQ[CirculantGraph[v,#],gr]&/@k,True]//Flatten

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[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[vi334,{0,Pi,Pi/15},1,2]

WriteLiveAnimationForm["crosspol.m",movie]