Animating moving surface of torus

Question

I would like to try to recreate something similar to Paolo Čerić's torus animation:

I have isolated the moving surface torus section from this Wolfram Demonstration by Kevin Sonnanburg:

t = s; s = .001; θ = 0; Manipulate[
Show[{ParametricPlot3D[{Cos[u] (3 + Cos[t]), Sin[u] (3 + Cos[t]), 
Sin[t]}, {u, Cos[θ] s - .5 + a, 
Cos[θ] s + .5 + a}, {t, Sin[θ] s - .5 + b, 
Sin[θ] s + .5 + b}, PlotPoints -> 4, PlotStyle -> Red, 
PerformanceGoal -> "Quality", PlotPoints -> 6, Axes -> None, 
Boxed -> False, Mesh -> None, PlotRange -> 4], 
ParametricPlot3D[{Cos[
a + v Cos[θ]] (3 + Cos[b + v Sin[θ]]), 
Sin[a + v Cos[θ]] (3 + Cos[b + v Sin[θ]]), 
Sin[b + v Sin[θ]]}, {v, 0, s}, PlotPoints -> 20]}, 
PlotRange -> 4, ImageSize -> {200, 200}, ViewAngle -> π/10],
{{a, π, "shift X"}, 0, 6 π},
{{b, π, "shift Y"}, 0, 6 π},
AutorunSequencing -> {2, 3, 4}, SaveDefinitions -> True]

I have tried to apply a texture to the section, and extend it over the whole torus, but I haven't made as much progress as I'd hoped.

Perhaps you can get something out of this, it looks OK but it's way too slow. — C. E., Apr 06 '14 at 01:21
I will do that if I (1) get time to create an animation that has the same speed/distances as the original and (2) Manage to make the code prettier and/or faster without making it the same as Kuba uses. I don't really like my current code, but thought I should make it available somehow. :) — C. E., Apr 06 '14 at 21:55

score 27 · Accepted Answer · edited Mar 29 '18 at 18:39

27

Let's get a black torus:

torus = First@ParametricPlot3D[{Cos[u] (3 + Cos[t]), Sin[u] (3 + Cos[t]), Sin[t]},
                               {u, 0, 2 Pi}, {t, 0, 2 Pi},
                               PlotStyle -> Black, Mesh -> None, PlotPoints -> 10]

and now, this is a way to go:

DynamicModule[{d1 = 0, d2 = 0},
 Column[{
   Graphics3D[{
     torus,
     Red, Dynamic[Riffle[
       Point /@ Array[
         {Cos[#] (3. + 1.01 Cos[#2]), Sin[#] (3. + 1.01 Cos[#2]), Sin[#2]} &,
         {65, 15},
         {{0 + d2/10, 2. Pi + d2/10}, {0. + d2, 2 Pi + d2}}]
       , {Yellow, Pink, LightBlue}
       ]]
     }
    , ImageSize -> 500, Background -> Black, Boxed -> False]
   ,

   Slider[Dynamic@d2, {0, 2. Pi, .01}]
   }]]

animation

Not perfect but I don't have time now for more efficient approach :/.

p.s. Array works this way on version 9. Use Table/Range for older versions.

edited Mar 29 '18 at 18:39

J. M.'s missing motivation

124,525
11
401
574

answered Apr 05 '14 at 18:35

Kuba

136,707
13
279
740

Amazing - how you can whip up something like that in 5 minutes ... I'll probably never know! :) – martin Apr 05 '14 at 18:47
1

@martin Thank you ;) I've added 1.01 for the tube radius so the points will not hide below black torus surface anymore :) – Kuba Apr 05 '14 at 19:15
Just nitpicking - how would you get the 'lights' to run diagonally? – martin Apr 05 '14 at 22:21
2

@martin you can flatten the array and riffle such way that each row starts from next color, then it will look like they are not vertical. – Kuba Apr 05 '14 at 22:56

score 7 · Answer 2 · answered Mar 29 '18 at 02:24

Here's my take:

torus lights

which was produced by

torus[c_, r_] := BSplineSurface[Map[Function[pt, Append[#1 pt, #2]],
                                {{1, 0}, {1, 1}, {-1, 1}, {-1, 0},
                                 {-1, -1}, {1, -1}, {1, 0}}] & @@@
                                (TranslationTransform[{c, 0}] /@
                                 (r {{1, 0}, {1, 1}, {-1, 1}, {-1, 0},
                                     {-1, -1}, {1, -1}, {1, 0}})),
                                SplineClosed -> True, SplineDegree -> 2, 
                                SplineKnots -> ConstantArray[{0, 0, 0, 1/4, 1/2,
                                                              1/2, 3/4, 1, 1, 1}, 2], 
                                SplineWeights -> Outer[Times, {1, 1/2, 1/2, 1,
                                                               1/2, 1/2, 1},
                                                              {1, 1/2, 1/2, 1,
                                                               1/2, 1/2, 1}]]

toreq[c_, r_][u_, v_] := N[{(c + r Cos[v]) Cos[u], (c + r Cos[v]) Sin[u], r Sin[v]}]

With[{c = 3, r = 1, m = 37, n = 17}, 
     Animate[Graphics3D[{{Black, torus[c, 0.98 r]}, 
                         Point[RotationTransform[2 φ, {0, 0, 1}] @
                               Flatten[Table[toreq[c, r][u, v + φ],
                                             {v, 0, 2 π, 2 π/(n - 1)},
                                             {u, 2 π, 0, -2 π/(m - 1)}], 1], 
                               VertexColors ->
                               Flatten[Table[{Cyan, Magenta, Yellow}[[Mod[k - j, 3] + 1]],
                                             {j, n}, {k, m}]]]},
                        Background -> Black, Boxed -> False],
             {φ, 0, 2 π, 2 π/(4 (n - 1))}]]

Animating moving surface of torus

2 Answers2

Linked