# How to create this four-dimensional cube animation?

This is a tesseract, a four-dimensional cube, which contains two cubes. Here, each side length of the smaller one is 1, while the side length of the bigger one is 2. How do make I it?

I am still working on it, and I wish to see different approaches.

• have a look at demonstrations.wolfram.com/ProjectionsOfTheFourCube for some more ideas Aug 18, 2012 at 14:09
• @cormullion Sorry, I'm not quite familar with projection,may be someone could do it Aug 18, 2012 at 15:05

My approach. The main distinguishing feature being the ridiculously clumsy and inefficient way of calculating the faces...

v = Tuples[{-1, 1}, 4];
e = Select[Subsets[Range[Length[v]], {2}], Count[Subtract @@ v[[#]], 0] == 3 &];
f = Select[Union[Flatten[#]] & /@ Subsets[e, {4}], Length@# == 4 &];
f = f /. {a_, b_, c_, d_} :> {b, a, c, d};
rotv[t_] = (RotationMatrix[t, {{0, 0, 1, 0}, {0, 1, 0, 0}} ].
RotationMatrix[2 t, {{1, 0, 0, 0}, {0, 0, 0, 1}} ].#) & /@ v;
proj[t_] := Most[#]/(3 - Last[#]) & /@ rotv[t];

Animate[Graphics3D[GraphicsComplex[proj[t],
{Cyan, Specularity[0.75, 10], Sphere[Range[16], 0.05],
Tube[e, 0.03], Opacity[0.3], Polygon@f}],
Boxed -> False, Background -> Black, PlotRange -> 1], {t, 0, Pi/2}]


• I did Select[Subsets[Range[Length[v]], {2}], SquaredEuclideanDistance @@ v[[#]] == 4 &] to pick out the edges myself... BTW, you could have done Sphere[Range[16], .05] and Polygon[f] within the GraphicsComplex[] object. Aug 18, 2012 at 17:03
• @J.M., thanks. Your edge selection is definitely better than mine, but it's the faces that I'm really embarrassed about ;-) Aug 18, 2012 at 17:17
• I can't condemn you there, since I used the exact same code to get the faces in my answer... :D Aug 18, 2012 at 17:23
• It turns out there's a really compact way to get the edges: GraphData["TesseractGraph", "EdgeIndices"]. As for enumerating faces, maybe one could adapt kguler's answer here. Aug 19, 2012 at 11:06
• i wonder if there is some creature out there in the universe that swims like this
– amr
Apr 15, 2013 at 17:23

Here is my (slightly less) modest attempt to depict the Clifford rotation (a.k.a. double rotation) of a hypercube, using perspective projection (i.e., a Schlegel diagram) to view the rotation (see this for a discussion on perspective projection):

tesseract = GraphicsComplex[
{{-1, -1, -1, -1}, {-1, -1, -1, 1}, {-1, -1, 1, -1}, {-1, -1, 1, 1}, {-1, 1, -1, -1},
{-1, 1, -1, 1}, {-1, 1, 1, -1}, {-1, 1, 1, 1}, {1, -1, -1, -1}, {1, -1, -1, 1},
{1, -1, 1, -1}, {1, -1, 1, 1}, {1, 1, -1, -1}, {1, 1, -1, 1}, {1, 1, 1, -1},
{1, 1, 1, 1}}, {{JoinForm["Round"], (* edges *)
Tube[{{1, 2}, {1, 3}, {1, 5}, {1, 9}, {2, 4}, {2, 6}, {2, 10}, {3, 4}, {3, 7},
{3, 11}, {4, 8}, {4, 12}, {5, 6}, {5, 7}, {5, 13}, {6, 8}, {6, 14}, {7, 8},
{7, 15}, {8, 16}, {9, 10}, {9, 11}, {9, 13}, {10, 12}, {10, 14}, {11, 12},
{11, 15}, {12, 16}, {13, 14}, {13, 15}, {14, 16}, {15, 16}}, 1/8]},
{Directive[Opacity[1/2], EdgeForm[]], (* faces *)
Polygon[{{1, 2, 4, 3}, {1, 2, 6, 5}, {1, 2, 10, 9}, {1, 3, 7, 5}, {1, 3, 11, 9},
{1, 5, 13, 9}, {2, 4, 8, 6}, {2, 4, 12, 10}, {2, 6, 14, 10}, {3, 4, 8, 7},
{3, 4, 12, 11}, {3, 7, 15, 11}, {4, 8, 16, 12}, {5, 6, 8, 7}, {5, 6, 14, 13},
{5, 7, 15, 13}, {6, 8, 16, 14}, {7, 8, 16, 15}, {9, 10, 12, 11},
{9, 10, 14, 13}, {9, 11, 15, 13}, {10, 12, 16, 14}, {11, 12, 16, 15},
{13, 14, 16, 15}}]}}];

With[{(* focal length *) f = 2,
(* distance to focal point *) d = 2,
(* frames *) n = 45,
(* for extracting axes *) ax = IdentityMatrix[4]},
Table[Graphics3D[{ColorData["Legacy", "Cobalt"], MapAt[Map[
Composition[
(* perspective transformation along axis {0, 1, 0, 0} *)
Function[pt, f Delete[pt, 2]/(d - Extract[pt, 2])],
(* Clifford rotation along orthogonal hyperplanes *)
RotationTransform[-θ, ax[[{3, 4}]]],
RotationTransform[θ, ax[[{1, 2}]]]], #] &, tesseract, {1}]},
Background -> Black, Boxed -> False, Lighting -> "Neutral",
PlotRange -> {{-3, 3}, {-5, 5}, {-5, 5}}, PlotRangePadding -> None,
ViewPoint -> {1.4, -2., 1.}], {θ, 0, 2 π, 2 π/(n - 1)}]]


Of note is that in assembling the transformation corresponding to a Clifford rotation, the order of application does not matter (i.e. the component rotations of a Clifford rotation are commutative); thus, both Composition[RotationTransform[-θ, ax[[{3, 4}]]], RotationTransform[θ, ax[[{1, 2}]]]] and Composition[RotationTransform[θ, ax[[{1, 2}]]], RotationTransform[-θ, ax[[{3, 4}]]]] will give the same result.

This is my approach, has nothing to do with projection, and it is a little complicated.

I get all coordinates and faces first to determine both start and end state. Then, change the start state smoothly to the end.

coor = Flatten[PolyhedronData["Cuboid", "VertexCoordinates"], 1];
face = Flatten[PolyhedronData["Cuboid", "FaceIndices"], 1];
edge = Flatten[PolyhedronData["Cuboid", "EdgeIndices"], 1];
coor1 = Join[coor, 2 coor];
coor2 = Join[2 coor[[1 ;; 4]], coor[[1 ;; 4]], 2 coor[[5 ;; 8]], coor[[5 ;; 8]]];
finalCoor[t_] := coor1 + (coor2 - coor1) t;(*t from 0 to 1*)
face1 = Join[face, face + 8];
finalface = Join[Join @@@ Thread[{edge, Reverse /@ (8 + edge)}], face1];
fourDimensions[scale_] := Table[Graphics3D[{Opacity[0.5],
Rotate[GraphicsComplex[finalCoor[t], Polygon[finalface]],
t π/2, {1, 0, 0}]}, Boxed -> False,
PlotRange -> {{-scale, scale}, {-scale, scale}, {-scale, scale}},
ViewPoint -> {-1.75, 0.75, 0.5}], {t, 0, 0.95, 0.05}];
Export["F:\\fourDimensionalCube.gif", fourDimensions[1.5]]


Here is the result:

• Note that finalCoor[] can be implemented in terms of Rescale[]: Rescale[t, {0, 1}, {coor1, coor2}] Aug 18, 2012 at 16:51
• @JM Thanks,you are right,Rescale lookes better Aug 19, 2012 at 1:19
• There's no more "Cuboid" in PolyhedronData, did it get renamed? Oct 19, 2020 at 16:55

I tried something similar last week, but with the 24-cell. Perhaps it can be modified for the tesseract.

Create a stereographic projection function from the 3-sphere (in $\mathbb{R}^4$) to $\mathbb{R}^3$:

Proj[{x1_, x2_, x3_, x4_}] := {x1, x2, x3}/(1 - x4);


Create a list of the 24 vertices. I got the coordinates from the wikipedia page for the 24-cell:

verts = Flatten[Permutations /@ {{1, 0, 0, 0}, {-1, 0, 0, 0}, {1/2, 1/2, 1/2, 1/2},
{-1/2, 1/2, 1/2, 1/2}, {-1/2, -1/2, 1/2, 1/2}, {-1/2, -1/2, -1/2, 1/2},
{-1/2, -1/2, -1/2, -1/2}}, 1];


We pick random axes for two rotations in $\mathbb{R}^4$. Each rotation is determined by 2 axes:

rvs = {RandomReal[1, 4], RandomReal[1, 4]};
rvs2 = {RandomReal[1, 4], RandomReal[1, 4]};


Rotate the vertices in $\mathbb{R}^4$ with respect to an angle parameter. We perform two rotations, an initial rotation, then a rotation which depends on a parameter. The reason we do this is to avoid having a vertex at "infinity", which doesn't look so nice. Then take pairs of vertices at a distance of $1$ from each other (in $\mathbb{R}^4$) to get the edges of the 24-cell:

CellEdges[t_] := Select[Tuples[Map[RotationMatrix[t, rvs].RotationMatrix[0.5, rvs2].# &,
verts], 2], (0.9 < Norm[#[[1]] - #[[2]]] < 1.1) &]


Stereographically project the vertices to $\mathbb{R}^3$, then plot the edges:

Animate[Show[Map[Graphics3D@Line@Map[Proj, #] &, CellEdges[t]], Boxed -> False],
{t, 0, 2 Pi, 2 Pi/100}]


Here's a GIF of a slight modification of the above code:

• It looks like you use the perspective projection,could you give the exact answer? Aug 18, 2012 at 15:11
• @paradox2 I think he stereographically projected the vertices, but not the edges. I did something similar for the 600-cell some time ago and as you can see the edges are rounded, not straight. By using Line the animation can easily be confused with a perspective projection.
– E.O.
Aug 19, 2012 at 7:01