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

2 Answers 2

27
$\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$
4
  • $\begingroup$ Amazing - how you can whip up something like that in 5 minutes ... I'll probably never know! :) $\endgroup$
    – martin
    Commented Apr 5, 2014 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
    Commented Apr 5, 2014 at 19:15
  • $\begingroup$ Just nitpicking - how would you get the 'lights' to run diagonally? $\endgroup$
    – martin
    Commented Apr 5, 2014 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
    Commented Apr 5, 2014 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 and acknowledge you have read our privacy policy.

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