21
$\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:

Improve this question
$\endgroup$
7
  • $\begingroup$ What have you tried? $\endgroup$ Commented Mar 19, 2020 at 18:37
  • $\begingroup$ I will add that, I’m stuck figuring out how to upload the animation right now:( $\endgroup$ Commented Mar 19, 2020 at 18:39
  • 6
    $\begingroup$ It's not a torus thingy, its technical name is a Moebius thingy. $\endgroup$ Commented Mar 19, 2020 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$ Commented Mar 20, 2020 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$ Commented Jun 26, 2020 at 16:10

1 Answer 1

Reset to default
28
+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", [email protected]}} ] ], {{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 ]
Improve this answer
$\endgroup$
3
  • $\begingroup$ Wheres the shininess? $\endgroup$ Commented Jul 10, 2021 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$ Commented Jul 10, 2021 at 22:53
  • $\begingroup$ @user5601 Ok, I think I have managed to get some kind of glow effect, see the updated answer $\endgroup$ Commented Jul 10, 2021 at 23:17

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.