# Animating moving surface of torus

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. Apr 6, 2014 at 1:21
• This is great - why not post this as an answer? Apr 6, 2014 at 9:11
• 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. :) Apr 6, 2014 at 21:55

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


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.

• Amazing - how you can whip up something like that in 5 minutes ... I'll probably never know! :) Apr 5, 2014 at 18:47
• @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, 2014 at 19:15
• Just nitpicking - how would you get the 'lights' to run diagonally? Apr 5, 2014 at 22:21
• @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, 2014 at 22:56

Here's my take:

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