Dynamic Epicycles
Here is a slight modernization of old code by Stan Wagon for generating epicycles, based on this paper by Frank Farris:
Options[EpicyclePlot] =
{AnimationRunning -> True, ColorFunction -> Automatic, "Frames" -> 16,
"Movie" -> True, "MovieTimeInterval" -> Automatic, PlotPoints -> 100,
"ShowWheels" -> True};
EpicyclePlot[{radii_, speeds_, offsets_}, {a_, b_},
opts : OptionsPattern[{EpicyclePlot, ParametricPlot, ListAnimate}]] :=
Module[{n = Length[radii], armEnds, centers, cf, fr, frn, mInt, pp, t},
mInt = OptionValue["MovieTimeInterval"] /. Automatic -> {a, b};
cf = OptionValue[ColorFunction] /.
Automatic -> (Lighter[Hue[#/(n + 1)]] &);
pp = ParametricPlot[{Cos[speeds t + offsets],
Sin[speeds t + offsets]}.radii, {t, a, b},
Evaluated -> True,
Evaluate[FilterRules[{opts} ~Join~
Options[EpicyclePlot],
Options[ParametricPlot]]],
Axes -> None, PlotRange -> All];
fr = OptionValue["Frames"];
frn = Table[armEnds = Transpose[{radii Cos[speeds t + offsets],
radii Sin[speeds t + offsets]}];
centers = FoldList[Plus, {0, 0}, armEnds];
Show[Graphics[If[TrueQ[OptionValue["ShowWheels"]],
Table[{Directive[cf[i], EdgeForm[Black]],
Disk[centers[[i]], radii[[i]]]},
{i, n}], {}]], pp,
Graphics[{AbsoluteThickness[1], Line[centers],
AbsolutePointSize[5], Point[centers]}],
FilterRules[{opts}, Options[Graphics]],
PlotRange -> (1.15 Total[radii])],
{t, mInt[[1]], mInt[[2]],
(mInt[[2]] - mInt[[1]])/(fr - Boole[fr > 1])}];
If[TrueQ[OptionValue["Movie"]] && fr > 1,
ListAnimate[frn, FilterRules[{opts} ~Join~ Options[EpicyclePlot],
Options[ListAnimate]]],
If[fr > 1, frn, Last[frn]]]]
Example:
EpicyclePlot[{{1, 1/2, 1/3}, {1, 7, -17}, {0, 0, π/2}}, {0, 2 π}, "Frames" -> 32]
The basic idea is fairly simple:
GraphicsComplex[
ReIm@Accumulate[epicycle @@ data],
{Point@Range[n + 1],
Line@Range[n + 1],
MapThread[Circle, {Range[n], data[[1]]}]
}]
In the above epicycle
computes each epicycle, in essentially the same way as ubpdqn as complex numbers, which are then added together with Accumulate
; ReIm
converts the complex numbers to cartesian coordinates. The graphics directives are the same no matter where the points are, so they can be coded in a GraphicsComplex
. To update the configuration to a new time, all that is required is to recompute the points with a new value for the time. This can be done with Table
, Animate
, Manipulate
, or as in the code below with Dynamic
and Clock
.
Fancy example
I gussied it up a bit with a trailing path to help with the visualization. Since I chose irrational-ratio angular velocities, the trajectory will not be periodic. Even the trailing path has constant directives; the motion is due to the points of the GraphicsComplex
being dynamically updated.
n = 5;
data = { (* set up for 5 cycles *)
Reverse[n + Range[n]^4/10 + Sort@RandomReal[1, n]], (* radii *)
Range[n]^1.1/Sqrt[n], (* angular velocities *)
RandomReal[2 Pi, n]}; (* phase shifts *)
Clear[t];
ClearAll[epicycle];
SetAttributes[epicycle, Listable];
epicycle[r0_, w0_, t0_] := r0 Exp[I w0 (t - t0)];
trail[t0_, len_] :=
ReIm[Total[epicycle @@ data] /. t -> t0 + Range[0., -len, -0.3/Max@Abs@data[[2]]]];
With[{e = epicycle @@ data, tr = trail[t, 3.], n = Length@data[[1]]},
Graphics[
GraphicsComplex[
(* points computed dynamically *)
Dynamic@ Join[{{0., 0.}}, ReIm@Accumulate[e /. t -> t0], tr /. t -> t0],
(* directives are fixed *)
{ (* trailing path *)
Line[Range[n + 2, n + Length@tr + 1],
VertexColors -> (Flatten[{List @@ ColorData[97, 1], #}] & /@
Sqrt@Rescale[-Range@Length@tr])],
(* epicycles *)
Point@Range[n + 1],
Line@Range[n + 1],
MapThread[Circle, {Range[n], data[[1]]}]
}],
PlotRange -> Total@data[[1]] + data[[1, -1]],
PlotRangePadding -> Scaled[.05], Frame -> True,
(* Clock drives the animation *)
PlotLabel -> Dynamic[t0 = Clock[{0, Infinity}]]
]
]
Update
Inspired by @Craig, @MichaelE2 and @J.M. and integrating varying aspects (but without the polish of all the options):
ep[{r_, a_, o_}, n_] :=
Module[{fun =
Function[x,
Accumulate@
Prepend[ReIm@MapThread[#1 Exp[I #2 x + I #3] &, {r, a, o}], {0,
0}]], col = RandomColor[Length@r], smin = Max[2 Pi/a], tab, g},
tab = Table[fun[j], {j, 0, smin, smin/n}];
g = Graphics[{Opacity[0.5],
MapThread[{#3, Disk[#1, #2]} &, {Most@#, r, col}], Red,
Point[Most@#], Purple, PointSize[0.02], Point[Last@#], Blue,
Line@tab[[All, -1]], Line@#}, PlotRange -> 1.15 Total@r] & /@
tab;
ListAnimate[g]]
So using J.M. input:
ep[{{1, 1/2, 1/3}, {1, 7, -17}, {0, 0, \[Pi]/2}},300]
Takes a little time to process:
Reassuringly similar (excepting color scheme to J.M.). Will work on making smoother (animation) in the time I do not have.
Orginal answer
This can be simplified and visualization only depends on $z0$ and $z1$:
f[a_, k_, t_] := a Exp[I k t];
t1 = 3;
t2 = 2;
a0 = 4;
g[x_] := Through[{Re, Im}[x]]
func[t_] := {{0, 0}, #1, #2, #1 + #2} & @@ (g /@ {f[a0, 2 Pi/t2, t],
f[a1, 2 Pi/t1, t]})
Visualizing:
Manipulate[
With[{res = func[t]},
Graphics[{Circle[res[[1]], a0], Circle[res[[2]], a1], Point[res],
Line[res[[{1, 3}]]], Line[res[[{2, 3}]]], Line[res[[{2, 4}]]],
Text["{0,0}", res[[1]], Offset[{3, 3}]],
Text["z0", res[[2]], Offset[{3, 3}]],
Text["z1", res[[3]], Offset[{3, 3}]],
Text["z2", res[[4]], Offset[{3, 3}]],
}, PlotRange -> {{-10, 10}, {-10, 10}}]], {t, 0, 12}]
I chose 12 as common multiple of periods.
A little generalization:
epic[r0_, r1_, tm0_, tm1_,
t_] := {{0, 0}, #1, #2, #1 + #2} & @@ (g /@ {f[r0, 2 Pi/tm0, t],
f[r1, 2 Pi/tm1, t]});
epivis[r0_, r1_, tm0_, tm1_, t_, col_, ps_: 0.02] :=
With[{res = epic[r0, r1, tm0, tm1, t]},
Graphics[{Circle[res[[1]], r0], Circle[res[[2]], r1], PointSize[ps],
Point[res[[1 ;; 3]]], col, Point[res[[4]]], Line[res[[{1, 3}]]],
Line[res[[{2, 3}]]], Line[res[[{2, 4}]]], Dashed,
Line[Table[
Last@epic[r0, r1, tm0, tm1, j], {j, 0, 2 tm0 tm1,
2 tm0 tm1/200}]]},
PlotRange -> Table[3 Max[r0, r1] {-1, 1}, {2}]]]
Example:
Manipulate[epivis[r0, r1, tm0, tm1, t, Red]
, {r0, 1, 2}, {r1, 2, 4}, {tm0, 2, 4}, {tm1, 2, 4}, {t, 0,
2 tm0 tm1}]