Can Mathematica create persistence of vision animations?

Question

The hyperbolic paraboloid is notoriously hard to visualize. One to do so is via cylindrical coordinates $$z = r^2 \cos 2 \theta$$ which suggest the following 3D visualization:

1. Start with a parabola pointing up. The parabola is a 2D figure, and we are looking straight at it.
2. Revolve it slowly, bending its arms down as it revolves, so that by the time its rotated 45°, its arms are flat, forming a straight line.
3. Keep revolving it and bending it down, so that by the time it's revolved 90°, it's arms point down.
4. Now keep revolving it, but begin bending it back up, at the same rate.
5. Continue this, and slowly increase the speed of revolution, so that eventually, when the revolution is fast enough, persistence of vision starts to keep the previous positions in your mind's eye, and you see the shape of the hyperbolic paraboloid form!

Is it possible to do this in Mathematica? Each frame would simply be a plot of $z = r^2 \cos 2 \theta$ for a single fixed $\theta$. The challenge is stringing the frames together into an animation, and playing it at a faster and faster frame rate.

Note: This question is distinct from the general questions of Making mathematical animations with Mathematica and Making mathematical animations with Mathematica , because it is specific to the technique of persistence of vision animations.

---

Update

Here's the code up to the point where we need to introduce persistence of vision:

n  = 100 (* Number of slices of theta *)
j = 10 (* The slice this frame is showing *)
RevolutionPlot3D[r^2 Cos[2\[Theta]] ,{r, 0,1}, {\[Theta], 2 \[Pi]*j/n, 2\[Pi]*(j+1)/n}]
(* Ideally I'd like Theta to also include {-2 \[Pi]*j/n, -2\[Pi]*(j+1)/n},
but I don't know how to do disjoint ranges *)

So far, so good. But now the question is: How to sweep j through 0 to n-1, initially slowly, then faster, all in the same exact plot frame, so that persistence of vision slurs these images together?

Doing

Animate[RevolutionPlot3D[r^2 Cos[2\[Theta]] ,{r, 0,1}, {\[Theta], 2 \[Pi]*s/n, 2\[Pi]*(s+1)/n}], {s, 0, 99}] 

doesn't work, since the plot frame is redrawn each time.

Answer 1

Let's break this into two problems. The first is to create a sequence of slices. What you've failed to do is orient your slices in 3D. There are probably several ways to do this, but here's one.

slices = 
  Table[
    ParametricPlot3D[
      {r Cos[t], r Sin[t], r^2 Cos[2 t]}, {r, -1, 1}, 
      PlotRange -> {-1, 1}, Axes -> False, Boxed -> False],
    {t, 0, 2 Pi, 2 Pi/100}];

This creates 100 slices, but you can adjust that as necessary going forward.

The next problem is to put these slices together into an animation. The easiest way would be

ListAnimate[slices]

You could also try FrameListVideo. And you can try Exporting to GIF or MP4 or whatever.

But, you want to be able to control the frame rate. Here we run into a problem, because while that option is available, the animation will need to be regenerated for each frame rate you want to try. So, frame rate changes won't be nice and smooth. But if you don't need smooth transitions between frame rate adjustments, then you can just generate each animation at each frame rate you want.

But now we run into a final problem. I've played around with this, and I cannot get a persistence of vision effect. There seems to be a bound on the frame rate or frame duration options, and so I can't get the animation to be fast enough. Adding more frames makes the animation smoother, but doesn't get me closer to POV. Maybe someone else knows more about generating animations/gifs/mp4s/etc.

I haven't tried making each frame a 2D "wedge" surface rather than a 1D cross section. But if we're going down that road, then we're giving up on actual persistence of vision anyway.

This particular example of a hyperbolic paraboloid may be part of the problem here. The frame rate for movies is only 24 frames per second, but that only works when changes between frames are small. When something is moving very fast, other visual effects interfere. Like the way wheels can appear to be spinning backward in a film. Your idea for animating the hyperbolic paraboloid uses rotation, and so we may run into similar problems.

So, if your true goal is persistence of vision, this particular example might not be the best case study. But if your goal is actually more like, "create a visualization that explains the structure of a surface in 3D by highlighting its slices", then we have more options. @azerbajdzan has provided a nice example of that.

Update based on comments

Here is how you can get some 2D to the slices (and I've also parameterized this a bit, so you can adjust the number of slices and the angular width of each slice).

slices =
  With[
    {count = 50},
    With[
      {sliceSize = 2 Pi/count},
      Table[
        ParametricPlot3D[{r Cos[t + s], r Sin[t + s], r^2 Cos[2 (t + s)]}, 
          {r, -1, 1}, 
          {s, 0, 5 sliceSize}, 
          PlotRange -> {-1, 1}, 
          Axes -> False, 
          Boxed -> False], 
        {t, 0, 2 Pi, sliceSize}]]];
ListAnimate[slices, 50]
(* This is just a single frame *)

Export as gif:

Answer 2

n = 35;
Table[ParametricPlot3D[
   Evaluate@
    Table[RotationMatrix[2 Pi fi - 0.1 q, {0, 0, 1}] . {x, 0, 
       x^2 Cos[2 (2 Pi fi - 0.1 q)]}, {q, 0, n}], {x, -1, 1}, 
   SphericalRegion -> Sphere[{0, 0, 0}, 1.5], PlotRange -> 1.5, 
   Boxed -> False, Axes -> False, ImageSize -> 640, 
   PlotStyle -> 
    Table[Directive[Opacity[q], Thin, ColorData[97, 1]], {q, 1, 
      0, -1/n}]], {fi, 0, 1 - 0.02, 0.02}];
Export["hp1.gif", %, "GIF", "DisplayDurations" -> 0.04]

---

n = 25;
Table[ParametricPlot3D[
   Evaluate@
    Table[RotationMatrix[2 Pi (fi - 0.02 q), {0, 0, 1}] . {x, 0, 
       x^2 Cos[2 (2 Pi (fi - 0.02 q))]}, {q, 0, n}], {x, -1, 1}, 
   SphericalRegion -> Sphere[{0, 0, 0}, 1.5], PlotRange -> 1.5, 
   Boxed -> False, Axes -> False, ImageSize -> 640, 
   PlotStyle -> 
    Table[Directive[Opacity[q], Thin, ColorData[97, 1]], {q, 1, 
      0, -1/n}]], {fi, 0, 1 - 0.02, 0.02}];
Export["hp2.gif", %, "GIF", "DisplayDurations" -> 0.04]

---

Personally I do not see any advantage using this animation over classical depicting of hyperbolic paraboloid.

ContourPlot3D[z == x^2 - y^2, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}]
RevolutionPlot3D[
 r^2 Cos[2 \[Theta] + 0 Pi/2], {r, 0, 1}, {\[Theta], 0, 2 \[Pi]}, 
 PlotRange -> 3/2, BoxRatios -> {1, 1, 1}]

---

Answer 3

This could be a start. I just calculate $z$ at the endpoints of a fixed time window and plot the Filling between the endpoints at each t. Note I don't do any blurring based on the time density of the plot in the time window.

We define a version of z where we can specify a speed

z[r_, t_, speed_] := r^2 Cos[t*speed];

We then define a time window centered at t:

(*define window size of t*)
window = 5*10^-2;

Then we plot the values at the endpoints of t, and fill in between

zPlotWindow[r_, t_, speed_] := Module[{tab, tVals},

  (*grab window endpoint t values*)
  tVals = {(t - window)/2, (t + window)/2};
  
  (*calculate z[r,t,speed] at the given tValues and speed*)
  tab = Table[z[r, tStar, speed], {tStar, tVals}];
  
  (*plot the filling between the two endpoints*)
  Plot[tab, {r, -1, 1}, PlotRange -> {{-1, 1}, {-1, 1}},
   PlotStyle -> None, Filling -> {1 -> {{2}, Gray}}]]

And animate:

anim = Animate[zPlotWindow[r, t, 5 t^2 + 1], {t, 0, Pi, window/2}]

Answer 4

• Another version of the excellent answer by @lericr

Clear[interval];
interval = 1/2;
ani=Manipulate[
 ParametricPlot3D[{r Cos[t + s], r Sin[t + s], 
   r^2 Cos[2 (t + s)]}, {r, -1, 1}, {s, t, t + interval}, 
  PlotRange -> {-1, 1}, Axes -> False, Boxed -> False, 
  PerformanceGoal -> "Quality"], {t, 0, 2 π}]

Export["ani.gif", ani, "ControlAppearance" -> None];
SystemOpen["ani.gif"]

• Or use the author's RevolutionPlot3D + RegionFunction

ani=Manipulate[
 RevolutionPlot3D[
  r^2 Cos[2 θ], {r, 0, 1}, {θ, 0, 2 π}, 
  BoxRatios -> 1, 
  RegionFunction -> 
   Function[{x, y, z, r, θ}, 
    RegionMember[
      ConicHullRegion[{{0, 0}}, {AngleVector[c], 
        AngleVector[c + 1/2]}], {x, y}] || 
     RegionMember[
      ConicHullRegion[{{0, 0}}, {AngleVector[π + c], 
        AngleVector[π + c + 1/2]}], {x, y}]], PlotRange -> 1, 
  PerformanceGoal -> "Quality"], {c, 0, 4 π}]