16
$\begingroup$

I came across a beautiful animation of a Möbius torus, and I'm hoping someone can help me make this animation in code:

enter image description here

What I've tried:

I made the basic shape but can't get the right colors, lighting & reflections, and rotation to work yet:

makeShape[vl_List, c1_Integer, c2_Integer] := Block[
   {l = vl,  l1 = RotateLeft /@ vl, mesh},
    mesh = {l, l1, RotateLeft[l1], RotateLeft[l]};
    If[c1 == 1, mesh = Map[Drop[#, -1] &, mesh, {1}] ];
    If[c2 == 1, mesh = Map[Drop[#, -1] &, mesh, {2}] ];
    Polygon /@ Transpose[ Map[Flatten[#, 1] &, mesh] ] 
       ];
data = Table[{Cos[u], Sin[u], 0} + 
    0.5 Cos[v] { Cos[u/2] Cos[u], Cos[u/2] Sin[u], Sin[u/2]} + .5 Sin[
      v] { -Sin[u/2] Cos[u], -Sin[u/2] Sin[u], Cos[u/2]}, {u, 0., 
    2 Pi, 2 Pi/15}, {v, 0, 2 Pi, 2 Pi/6}];
Graphics3D[{GoochShading[], makeShape[data, 1, 1]}, Boxed -> False, 
 ImageSize -> {550, 400}, SphericalRegion -> True,
 Lighting -> "Accent", 
 Background -> RGBColor @@ {{0.1333, 0.1137, 0.5333, 1.}}]

enter image description here

References:

I've found these related resources:

$\endgroup$
7
  • $\begingroup$ What have you tried? $\endgroup$ Mar 19 '20 at 18:37
  • $\begingroup$ I will add that, I’m stuck figuring out how to upload the animation right now:( $\endgroup$
    – user5601
    Mar 19 '20 at 18:39
  • 5
    $\begingroup$ It's not a torus thingy, its technical name is a Moebius thingy. $\endgroup$ Mar 19 '20 at 19:19
  • 7
    $\begingroup$ This is not a 3D object. It is a sequence of 16 identical hexagons arranged in a circle. The corresponding vertices of the neighbouring hexagons are joined to form a "face". The hexagons are then rotated in unison about their individual centres to create the animation. The tricky bit is working out the z-ordering of the faces to draw it correctly. The colouring is also somewhat artistic. It doesn't have any consistency for the specular flashes. $\endgroup$
    – wxffles
    Mar 20 '20 at 2:41
  • 1
    $\begingroup$ You can get rotation by putting the thing in a Manipulate and adding a phase to both Sin[v] as Sin[v+p] and Cos[v] as Cos[v+p], and varying the p from 0 to 2pi $\endgroup$
    – flinty
    Jun 26 '20 at 16:10
16
+100
$\begingroup$

Update: I have managed to fix the distortion of the polygons, so now only the glow is missing

Update 2: I have added a hacky "glow" to the polygons by adding partially transparent polygons slightly above the white polygons to give them some kind of "volumetric glow"

Update 3: I have tweaked the lighting settings a bit to give the image a bit more depth

Here is my attempt (code below):

enter image description here

(* the color function to be used by the animation *)
colorfunc = Blend[{
  {0, RGBColor[2/17, 8/51, 26/51]}, 
  {0.9, RGBColor[7/51, 176/255, 188/255]},
  {1, RGBColor[1, 1, 1]}
 }, #] &;
BarLegend[{colorfunc, {0, 1}}, LegendLayout -> "Row"]

(* for each polygon, generate a random function moving between 0 and 1 over the interval from 0 to 2π *)
Clear@colors;
colors[i_, j_] := colors[i, j] = (
   SeedRandom[ToString[{i, j}]];(* make outcome predictable *)
   Interpolation[ReplacePart[#, {-1, 2} -> #[[1, 2]]] &@Table[{x, RandomReal[]}, {x, Subdivide[0, 2 π, 8]}], PeriodicInterpolation -> True]
   )

(* precompute the rotation matrices for improved performance *)
rx = Evaluate@RotationMatrix[#, {1, 0, 0}] &
ry = Evaluate@RotationMatrix[#, {0, 1, 0}] &
rz = Evaluate@RotationMatrix[#, {0, 0, 1}] &
(* {{1, 0, 0}, {0, Cos[#1], -Sin[#1]}, {0, Sin[#1], Cos[#1]}} & *)
(* {{Cos[#1], 0, Sin[#1]}, {0, 1, 0}, {-Sin[#1], 0, Cos[#1]}} & *)
(* {{Cos[#1], -Sin[#1], 0}, {Sin[#1], Cos[#1], 0}, {0, 0, 1}} & *)

Manipulate[
 With[{pt = Mod[If[#2 == m + 1, l, 0] + # - 1, n] + Mod[If[# == n + 1, k, 0] + #2 - 1, m] n + 1 &},
  Graphics3D[
   Dynamic@GraphicsComplex[
     
     Catenate@Catenate@Table[(*generate the points*)
        rz[2 π (i + l j/m)/n].(
          {1, 0, 0} + rx[u].({1, 1, 1/Cos[u]} ry[2 π (j/m + (k/m (i + l j/m))/n) + t].{s r, 0, 0})
          ),
        {s, Subdivide[1, 1.2, 6]},(*add scaled versions of the polygon for the glow effect*)
        {j, m},
        {i, n}
        ],
     {
      EdgeForm@{Thick, Black},
      Table[With[{i = i, j = j},
        Catenate@Table[
          If[s == 0 || # > 0.9,
             {(*if the brigthness is >0.9, enable the volumetric glow by showing the scaled polygons*)
              If[s > 0,
               Splice@{EdgeForm@None, Opacity[5 (1 - s/8) (# - 0.9)]},
               {}
               ],
              Polygon[(*specify the polygons using the points above*)
               {pt[i, j], pt[i + 1, j], pt[i + 1, j + 1], pt[i, j + 1]} + s n m,
               BaseStyle -> {colorfunc[#], Glow@GrayLevel[#^10]}
               ]
              }, {}] &@colors[i, j][t],
          {s, 0, 6}
          ]
        ],
       {j, m}, {i, n}
       ]
      }
     ],
   ViewPoint -> ({0.3, 0, 1}; {0, 0, ∞}),
   ViewVertical -> {0, 1, 1},
   Boxed -> False,
   SphericalRegion -> True,
   Background -> Darker@RGBColor[2/51, 8/51, 26/51],
   PlotRange -> 2,
   Lighting -> {{"Point", White, {-1.6, 1.6, 1}}, {"Point", White, {-1.6, 1.6, 1}}, {"Ambient", GrayLevel@0.3}}
   ]
  ],
 {{n, 16}, 3, 20, 1},(*twist-offset along the big circle*)
 {{m, 6}, 3, 10, 1},(*twist-offset along the small circle*)
 {{k, 6}, -10, 10, 1},(*animation time*)
 {{l, 0}, -3, 3, 1},(*tilt of the small circles*)
 {{t, π/4}, 0, 2 π, AnimationRate -> 0.1, Appearance -> "Open"},(*z-rotation offset for the inner edge of the torus*)
 {{u, -π/4}, -π/4, π/4},(*z-rotation offset for the outer edge of the torus*)
 {{r, 0.4}, 0.1, 0.9},(*radius of the small circle*)
 ControlPlacement -> Left
 ]
$\endgroup$
3
  • $\begingroup$ Wheres the shininess? $\endgroup$
    – user5601
    Jul 10 at 21:57
  • $\begingroup$ @user5601 As I have noted in the answer, I am not sure whether this can really be done in Mathematica $\endgroup$
    – Lukas Lang
    Jul 10 at 22:53
  • $\begingroup$ @user5601 Ok, I think I have managed to get some kind of glow effect, see the updated answer $\endgroup$
    – Lukas Lang
    Jul 10 at 23:17

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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