11
$\begingroup$

Thanks to all the thorough answers and comments, I've written the following code for an arbitrary number of epicycles. However, when I apply the formula $\gamma(t)=e^{it}+\frac{1}{2}e^{7it}+\frac{i}{3}e^{-17it}$ and print a few points along the path of the last circle, I do not get the same drawing as you guys do in the comments. Can you see what is wrong? Your help is much appreciated!

 Clear["Global`*"]
  n = 3;

 radii = {1/3, 1/2, 1};
 angularVel = {-17, 7, 1}
 circles = Table[radii[[i]]*E^(I*angularVel[[i]]*t), {i, 1, n}];
 circleCoords = 
 Table[{N[Re[circles[[i]]]], N[Im[circles[[i]]]]}, {i, 1, n}];
 harmonicCircles = 
 Table[Sum[circleCoords[[j]], {j, i + 1, n}], {i, 1, n - 1}];
 AppendTo[harmonicCircles, {0, 0}];


 (*--------------------------------------*)
 circlesForGraphic = 
 Table[Circle[harmonicCircles[[i]], radii[[i]]], {i, 1, n - 1}];
 PrependTo[circlesForGraphic, Circle[{0, 0}, radii[[n]]]];

 ordering = 
 Table[Text[i, harmonicCircles[[i]], Offset[{3, 3}]], {i, 1, n}];
 PrependTo[ordering, Text[n, {0, 0}, Offset[{3, 3}]]];





 epicyclesGraphic = 
 Graphics[{PointSize[0.002], Point[{0, 0}], ordering, 
 Point[harmonicCircles], circlesForGraphic}, PlotRange -> n*5];

 {Slider[Dynamic[t], {0, n}], Dynamic[t]}

 Dynamic[circleCoords]
 Dynamic[epicyclesGraphic]

 var = 300;
 data = {};
 For[t = 1, t <= var, t = t + 0.1,

 AppendTo[data, harmonicCircles[[1]]];

 ]

 ListPlot[data]
 ListCurvePathPlot[data, PlotTheme -> "Detailed"]

EDIT: It seems like I'm not adding the last circle. I need to also consider the point rotating along the last circle and trace its path. Let me get to it.

$\endgroup$

migrated from mathematica.meta.stackexchange.com Nov 21 '15 at 4:52

This question came from our discussion, support, and feature requests site for users of Wolfram Mathematica.

18
$\begingroup$

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]

you should really read Farris's paper

$\endgroup$
  • $\begingroup$ such a beautiful answer...I think MichaelE2 or yours are better than mine and have written to Craig...:) $\endgroup$ – ubpdqn Nov 22 '15 at 0:17
  • $\begingroup$ p.s.: I have been playing with this...it is very enjoyable and the code has taught me a lot: thank you :) $\endgroup$ – ubpdqn Nov 22 '15 at 1:14
  • $\begingroup$ @ubpdqn, you'll have to thank Stan Wagon; I only modernized his code. :) Now, after seeing Michael's code, I'm thinking one might be able to have the best of both, but I'll need to mull this over further. $\endgroup$ – J. M. will be back soon Nov 22 '15 at 2:38
16
$\begingroup$

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

enter image description here

$\endgroup$
  • $\begingroup$ this is beautiful...I always enjoy the fading trails and irrational ratios make interesting viewing +1 :) $\endgroup$ – ubpdqn Nov 22 '15 at 0:11
  • $\begingroup$ ps: thank you for introducing me to ReIm...never ceses to amaze me how much I miss! $\endgroup$ – ubpdqn Nov 22 '15 at 0:24
  • $\begingroup$ @ubpdqn Thanks! I let it run for a while, while I was doing something else. With thousands of functions, it's easy to miss one or two. The Listable attribute of ReIm is really useful here; otherwise, I feel it's somewhat like having a two-headed hammer in the toolbox. (I suppose if someone is using an early version, they could use ReIm = Function[z, {Re[z], Im[z]}, Listable].) $\endgroup$ – Michael E2 Nov 22 '15 at 0:53
  • $\begingroup$ @Michael E2 This is one of the best answers I've ever received! Thanks a lot. My problem for the time being seems to be how to wield this code I've created that generates a variable number of epicycles to follow a specific path. For example, in that paper you use for your curve by Frank Farris, they look at the parametric $\gamma(t)=e^{it}+\frac{1}{2}e^{7it}+\frac{i}{3}e^{-17it}$ If I simply enter those three terms as my points dependent on t, my code prints a different (albeit similarly symmetric) shape, not the one you have up here and they have in the paper. $\endgroup$ – Mike Nov 22 '15 at 0:54
  • 2
    $\begingroup$ @BoC. Ah, that's a V10 color, too. I missed that. Try Blue instead of ColorData[97, 1], or whatever your favorite color is. The code is constructing RGBColor of the form RGBColor[r, g, b, a], where rgb determines the color, and a determines the transparency. Sqrt@Rescale[-Range@Length@tr] gives a list of transparencies between 0 and 1, that fade suddenly at the end (the way a square-root graph suddenly dives toward the origin). $\endgroup$ – Michael E2 Jun 25 '16 at 18:57
12
$\begingroup$

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:

enter image description here

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.

enter image description here

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

enter image description here

$\endgroup$
  • $\begingroup$ that's beautiful, thank you for your thorough answer. I've figured out a way to generalize the process so that the user can choose the number of epicycles, with random periods, radii and angular velocities, and they output is "n" epicycles that can rotate dynamically. Now, what I would really like to do is make my code so that given any B-Spline that the user inputs (I have an interactive B-Spline maker so the user can make their own B-Spline), the program produces the epicycles that would "trace" this curve using the Fourier transform. $\endgroup$ – Mike Nov 21 '15 at 12:25
  • $\begingroup$ @Craig, that sounds like a harder problem. You'll probably want to restrict yourself to closed B-splines, as those are the sort of thing trigonometric approximation is useful for. $\endgroup$ – J. M. will be back soon Nov 21 '15 at 16:02
  • $\begingroup$ @Craig you know your ultimate aim, develop it and go if you hit stumbling block the community here I am sure will help. I think that both MichaelE2's and J.M. answers are much better answers than mine. I encourage to accept one of theirs. They are very very instructive. $\endgroup$ – ubpdqn Nov 22 '15 at 0:30
2
$\begingroup$

Thanks to all the thorough input from everyone in this section, I built the following code that produces a variable number of epicycles. I applied $\gamma(t)=e^{it}+\frac{1}{2}e^{7it}+\frac{i}{3}e^{-17it}$ to this, and sure enough the sum of the circles traces the path of this parametric.

My next step is to make a module out of this, and connect it to a B-Spline maker program so that the user can draw any closed B-Spline and watch the discrete fourier at work!

 Clear["Global`*"]
 n = 3;

 radii = {i/3, 1/2, 1};
 angularVel = {-17, 7, 1}
 circles = Table[radii[[i]]*E^(I*angularVel[[i]]*t), {i, 1, n}];
 circleCoords = 
 Table[{N[Re[circles[[i]]]], N[Im[circles[[i]]]]}, {i, 1, n}];
 harmonicCircles = 
 Table[Sum[circleCoords[[j]], {j, i + 1, n}], {i, 1, n - 1}];
 AppendTo[harmonicCircles, {0, 0}];
 lastPoint=Sum[circleCoords[[i]],{i,1,n}]


 (*--------------------------------------*)
 circlesForGraphic = 
 Table[Circle[harmonicCircles[[i]], radii[[i]]], {i, 1, n - 1}];
 PrependTo[circlesForGraphic, Circle[{0, 0}, radii[[n]]]];

 ordering = 
 Table[Text[i, harmonicCircles[[i]], Offset[{3, 3}]], {i, 1, n}];
 PrependTo[ordering, Text[n, {0, 0}, Offset[{3, 3}]]];





 epicyclesGraphic = 
 Graphics[{PointSize[0.002], Point[{0, 0}], ordering, 
 Point[harmonicCircles], circlesForGraphic}, PlotRange -> n*5];

 {Slider[Dynamic[t], {0, n}], Dynamic[t]}

 Dynamic[circleCoords]
 Dynamic[epicyclesGraphic]

 var = 300;
 data = {};
 For[t = 1, t <= var, t = t + 0.1,



 AppendTo[data, lastPoint];

 ]

 ListPlot[data]
 ListCurvePathPlot[data, PlotTheme -> "Detailed"]

enter image description here

$\endgroup$

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.