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.
graphics animation geometry
J. M.'s ennui♦
withparadox2withparadox2
$\begingroup$ have a look at demonstrations.wolfram.com/ProjectionsOfTheFourCube for some more ideas $\endgroup$ – cormullion Aug 18 '12 at 14:09
$\begingroup$ @cormullion Sorry, I'm not quite familar with projection,may be someone could do it $\endgroup$ – withparadox2 Aug 18 '12 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}]
Simon WoodsSimon Woods
$\begingroup$ 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. $\endgroup$ – J. M.'s ennui♦ Aug 18 '12 at 17:03
$\begingroup$ @J.M., thanks. Your edge selection is definitely better than mine, but it's the faces that I'm really embarrassed about ;-) $\endgroup$ – Simon Woods Aug 18 '12 at 17:17
$\begingroup$ I can't condemn you there, since I used the exact same code to get the faces in my answer... :D $\endgroup$ – J. M.'s ennui♦ Aug 18 '12 at 17:23
$\begingroup$ 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. $\endgroup$ – J. M.'s ennui♦ Aug 19 '12 at 11:06
$\begingroup$ i wonder if there is some creature out there in the universe that swims like this $\endgroup$ – amr Apr 15 '13 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.
J. M.'s ennui♦J. M.'s ennui
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:
$\begingroup$ Note that finalCoor[] can be implemented in terms of Rescale[]: Rescale[t, {0, 1}, {coor1, coor2}] $\endgroup$ – J. M.'s ennui♦ Aug 18 '12 at 16:51
$\begingroup$ @JM Thanks,you are right,Rescale lookes better $\endgroup$ – withparadox2 Aug 19 '12 at 1:19
$\begingroup$ There's no more "Cuboid" in PolyhedronData, did it get renamed? $\endgroup$ – Yaroslav Bulatov Oct 19 '20 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:
AhmadAhmad
$\begingroup$ It looks like you use the perspective projection,could you give the exact answer? $\endgroup$ – withparadox2 Aug 18 '12 at 15:11
$\begingroup$ @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. $\endgroup$ – E.O. Aug 19 '12 at 7:01
Not the answer you're looking for? Browse other questions tagged graphics animation geometry or ask your own question.
Cycles of length N in a graph
Stereographic Projection
How to visualize a 4-dimensional parametric surface?
Manipulatable Geometry from an Image
How to plot a 4-dimensional relation in an animated way?
Spreading colors in ListDensityPlot
How to keep different animation durations for two variables in the same animation
Allow multiple GUI elements to react dynamically to interaction with a single element
Create GIF looping animation
Plot four dimensional data consisting of discrete and continuous variables?
Construct, in some manner, a four-dimensional "RegionPlot"
HalfLine to draw lines "to infinity"
How to make specific physics animation