How to create this four-dimensional cube animation?

Question

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.

Answer 1

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}]

Answer 2

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.

Answer 3

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:

Answer 4

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: