How to create this four-dimensional cube animation?

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:

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: