2
$\begingroup$

I'm making a simple animation of wave motion. Each point is supposed to be moving exactly along a circle, and for some reason the purple & orange points seem to shake as they rotate about their respective circles. All of the arguments that determine the position of the point are $\mathcal{O}(10)$ or less, so I have trouble thinking is a rounding error.

The gif I've attached is rendered at 300 frames for just one cycle (which ought to be more than enough), and I can't seem to figure out how to go about correcting this. Any help is appreciated.


k = 2 \[Pi]/3;
c = Sqrt[9.82/k];

X[a_, b_, t_, k_ : k] := a + Exp[k*b]/k *Sin[k*(a - c*t)];
Y[a_, b_, t_, k_ : k] := b - Exp[k*b]/k *Cos[k*(a - c*t)];

r[b_, k_ : k] := Exp[k*b]/k;


ymax = -.3
ny = 10;
ys = Table[b, {b, ymax, -2, -(ymax + 2)/ny}];

parts[t_] := 
  Flatten[Table[
    Point[{X[a, b, t], Y[a, b, t]}], {a, -4, 4, .4}, {b, 
     ymax, -2, -(ymax + 2)/ny}], 1];

surf[t_] := Table[{X[a, ymax, t], Y[a, ymax, t]}, {a, -4, 4, .1}];
bot[t_] := Table[{X[a, -2, t], Y[a, -2, t]}, {a, -4, 4, .4}];
ledge[t_] := 
  Table[{X[-4, b, t], Y[-4, b, t]}, {b, ymax, -2, -(ymax + 2)/ny}];
redge[t_] := 
  Table[{X[4, b, t], Y[4, b, t]}, {b, ymax, -2, -(ymax + 2)/ny}];

highlight[t_] := {RGBColor["#f9a428"], PointSize[Medium], 
   Point[{X[0, ymax, t], Y[0, ymax, t]}], 
   Circle[{0, ymax}, r[ymax, k]], 
   Point[{X[0, ys[[4]], t], Y[0, ys[[4]], t]}], 
   Circle[{0, ys[[4]]}, r[ys[[4]], k]]};

show[t_] := Show[
   Graphics[{RGBColor["#1fb4b8"], 
     Polygon[Join[surf[t], bot[t], ledge[t], redge[t]]]}],
   Graphics[{PointSize[Medium], Lighter[RGBColor["#47245e"], .1], 
     parts[t]}],
   Graphics[highlight[t]],
   PlotRange -> {2 {-1, 1}, 2 {-1, .1}}, ImagePadding -> 0];


Manipulate[show[t], {t, 0, 2 Pi/(k c)}]
$\endgroup$
2
3
$\begingroup$

You could try using Show at a higher ImageSize and then use Rasterize to lower the image size like so:

k = 2 π/3;
c = Sqrt[9.82/k];

X[a_, b_, t_, k_ : k] := a + Exp[k*b]/k*Sin[k*(a - c*t)];
Y[a_, b_, t_, k_ : k] := b - Exp[k*b]/k*Cos[k*(a - c*t)];

r[b_, k_ : k] := Exp[k*b]/k;


ymax = -.3
ny = 10;
ys = Table[b, {b, ymax, -2, -(ymax + 2)/ny}];

parts[t_] := 
  Flatten[Table[
    Point[{X[a, b, t], Y[a, b, t]}], {a, -4, 4, .4}, {b, 
     ymax, -2, -(ymax + 2)/ny}], 1];

surf[t_] := Table[{X[a, ymax, t], Y[a, ymax, t]}, {a, -4, 4, .1}];
bot[t_] := Table[{X[a, -2, t], Y[a, -2, t]}, {a, -4, 4, .4}];
ledge[t_] := 
  Table[{X[-4, b, t], Y[-4, b, t]}, {b, ymax, -2, -(ymax + 2)/ny}];
redge[t_] := 
  Table[{X[4, b, t], Y[4, b, t]}, {b, ymax, -2, -(ymax + 2)/ny}];

highlight[t_] := {RGBColor["#f9a428"], PointSize[0.01], 
   Point[{X[0, ymax, t], Y[0, ymax, t]}], 
   Circle[{0, ymax}, r[ymax, k]], 
   Point[{X[0, ys[[4]], t], Y[0, ys[[4]], t]}], 
   Circle[{0, ys[[4]]}, r[ys[[4]], k]]};

show[t_] := 
  Rasterize[
   Show[Graphics[{RGBColor["#1fb4b8"], 
      Polygon[Join[surf[t], bot[t], ledge[t], redge[t]]]}], 
    Graphics[{PointSize[0.01], Lighter[RGBColor["#47245e"], .1], 
      parts[t]}], Graphics[highlight[t]], 
    PlotRange -> {2 {-1, 1}, 2 {-1, .1}}, ImageSize -> 1600, 
    ImagePadding -> 0], RasterSize -> 1600, ImageSize -> 800];
Manipulate[show[t], {t, 0, 2 Pi/(k c)}]
$\endgroup$
1
  • $\begingroup$ That works perfect, thanks! $\endgroup$ – InertialObserver Dec 15 '20 at 0:28

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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