19
$\begingroup$

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.

$\endgroup$
  • 1
    $\begingroup$ Perhaps you can get something out of this, it looks OK but it's way too slow. $\endgroup$ – C. E. Apr 6 '14 at 1:21
  • $\begingroup$ This is great - why not post this as an answer? $\endgroup$ – martin Apr 6 '14 at 9:11
  • 1
    $\begingroup$ 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. :) $\endgroup$ – C. E. Apr 6 '14 at 21:55
26
$\begingroup$

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.

$\endgroup$
  • $\begingroup$ Amazing - how you can whip up something like that in 5 minutes ... I'll probably never know! :) $\endgroup$ – martin Apr 5 '14 at 18:47
  • 1
    $\begingroup$ @martin Thank you ;) I've added 1.01 for the tube radius so the points will not hide below black torus surface anymore :) $\endgroup$ – Kuba Apr 5 '14 at 19:15
  • $\begingroup$ Just nitpicking - how would you get the 'lights' to run diagonally? $\endgroup$ – martin Apr 5 '14 at 22:21
  • 2
    $\begingroup$ @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. $\endgroup$ – Kuba Apr 5 '14 at 22:56
7
$\begingroup$

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))}]]
$\endgroup$

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.