Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

I have isolated the moving surface torus section form 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]

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

share|improve this question
1  
Perhaps you can get something out of this, it looks OK but it's way too slow. –  Pickett Apr 6 at 1:21
    
This is great - why not post this as an answer? –  martin Apr 6 at 9:11
1  
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. :) –  Pickett Apr 6 at 21:55

1 Answer 1

up vote 16 down vote accepted

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}]
   }]]

enter image description here

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

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

share|improve this answer
    
Amazing - how you can whip up something like that in 5 minutes ... I'll probably never know! :) –  martin Apr 5 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 5 at 19:15
    
Just nitpicking - how would you get the 'lights' to run diagonally? –  martin Apr 5 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 5 at 22:56

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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