Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

rotating tesseract

share|improve this question
    
have a look at demonstrations.wolfram.com/ProjectionsOfTheFourCube for some more ideas –  cormullion Aug 18 '12 at 14:09
    
@cormullion Sorry, I'm not quite familar with projection,may be someone could do it –  withparadox2 Aug 18 '12 at 15:05

4 Answers 4

up vote 27 down vote accepted

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

enter image description here

share|improve this answer
1  
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. –  J. M. Aug 18 '12 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 ;-) –  Simon Woods Aug 18 '12 at 17:17
1  
I can't condemn you there, since I used the exact same code to get the faces in my answer... :D –  J. M. Aug 18 '12 at 17:23
    
+1 My gosh, your animation looks perfect,and I'm going to accept this anser:) –  withparadox2 Aug 19 '12 at 1:24
1  
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. –  J. M. Aug 19 '12 at 11:06

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) &]

Stereographic 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.

share|improve this answer
    
It looks like you use the perspective projection,could you give the exact answer? –  withparadox2 Aug 18 '12 at 15:11
1  
@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 '12 at 7:01

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:

rotating tesseract

share|improve this answer
    
Note that finalCoor[] can be implemented in terms of Rescale[]: Rescale[t, {0, 1}, {coor1, coor2}] –  J. M. Aug 18 '12 at 16:51
    
@JM Thanks,you are right,Rescale lookes better –  withparadox2 Aug 19 '12 at 1:19

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

rotating tesseract

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.

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.