Animating moving surface of torus
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.
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))}]]