Skip to main content

plotting - How to graph the contour of a resulting Manipulate curve


How can the green contour be graphed?


enter image description here


FourierF[a_, t_] := a.Table[Sin[ 2 Pi i t], {i, Length[a]}];

FourierAnim[a_, t_] :=
Module[{
A = Accumulate[a*Table[Cos[ 2 Pi i t], {i, Length[a]}]],
B = Accumulate[a*Table[Sin[2 Pi i t], {i, Length[a]}]]},

PrependTo[A, 0]; PrependTo[B, 0];
Show[
Graphics[
Table[
{Circle[{A[[i]], B[[i]]}, a[[i]]],
Darker[Red],
If[i != Length@a,
Line[{{A[[i]], B[[i]]}, {A[[i + 1]], B[[i + 1]]}}],
{Red, Dashed, Line[{{A[[i]], B[[i]]}, {2, B[[i]]}}]}]


(* next line needs to be fixed *)
, {Green, Line[Table[{m, n}, {m, A[[i]], t}, {n, B[[i]], t}]]}
(* end of section needing editing *)

},
{i, Length@a}
],
PlotRange -> {{-1.5, 3}, {-1, 1}}
],
Plot[FourierF[a[[;; -2]], t - \[Tau]], {\[Tau], 2, 3}]

]
];

a = Table[(1 - (-1)^i)/i, {i, 64}]/Pi;
(* (1+(-1)^i)/i,{i,65} for sawtooth wave *)
(* ??? for triangle wave *)

Manipulate[
FourierAnim[
a[[;; j]], t], {t, 0, 1}, {j, 8, Length@a, 2}

]
(* {t,0,0.5},{j,9,Length@a,2} for sawtooth wave *)
(* ??? for triangle wave *)

The code is a modified version of the original; it demonstrates how the smooth motion of rotating circles can be used to build up any repeating curve.


The eventual solution was suggested by user Michael E2 in a comment from the second related thread posted below.



Can you make a list of the points and use Line? You seem to be able to calculate the points at each time (in order to draw the figure). Just make a Table of them over one period with suitable increment of time.



One of the early attempts of coding this was left uncommented, because it is the only one that produced visible related results. I now understand the error in Table and the array it generates, but this example is perfect for showing the confusion of a beginner. The solution will help me a lot in learning through examples.



Additional question:
What exactly needs to be changed in the formula 1-(-1)^i)/i in order to make (an approximation of) a triangle wave?



Answer



Generating the outline


By looking at the code we can infer that the position of the center of the outermost circle is given by


outline[a_, t_] := Module[{
A = Accumulate[a Table[Cos[2 Pi i t], {i, Length[a]}]],
B = Accumulate[a Table[Sin[2 Pi i t], {i, Length[a]}]]
}, {Last[A], Last[B]}]


This code comes straight from the one you posted; each element in A and B are the $x$ and $y$ coordinates of the subsequent circles. The last elements represent the positions of the outermost circle.


We can now plot the outline using ParametricPlot:


a = Table[(1 - (-1)^i)/i, {i, 16}]/Pi;
ParametricPlot[outline[a, tmax], {tmax, 0, 1}]

Mathematica graphics


The above outline was generated as if there were sixteen circles in the model. You can change the number 16 to get another outline.


We can append this function to Show inside the original function to draw the outline together with the animation.


Show[..., ..., ParametricPlot[outline[a, tmax], {tmax, 0, t}]]


We have to make a small change in the call to Manipulate because we can't plot from 0 to 0, so we increase the lower bound slightly:


Manipulate[FourierAnim[a[[;; j]], t], {t, 0.001, 1}, {j, 1, Length@a, 1}]

enter image description here


The triangle wave


As for your second question about the triangle wave we have to look at the math. The Fourier series of the square wave is $$ f(x) = \frac{4}{\pi}\sum_{i=1,3,5,...}^{\infty}\frac{1}{i}\sin\left(\frac{i\pi x}{L}\right) $$ and the corresponding code that we used is


a = Table[(1 - (-1)^i)/i, {i, 16}]/Pi;
FourierF[a_, t_] := a.Table[Sin[ 2 Pi i t], {i, Length[a]}];

Note that the sum in the Fourier series only sums over odd indices. The 1-(-1)^i part captures this behavior, because it is zero for even i. The other part of the formula is 1/i, and this is the coefficient of the Sin function in the Fourier series. We don't have to match the constants, it's enough that what we have is proportional to the Fourier series.



The Fourier series of the triangle wave is $$ f(x) = \frac{8}{\pi^2}\sum_{i=1,3,5,...}^{\infty}\frac{(-1)^{(i-1)/2}}{i^2}\sin\left(\frac{i \pi x}{L}\right). $$ Like the square wave Fourier series it is a Sin Fourier series that only sums over odd indices. So we can surmise that our expression will have two parts just like above; one part to set the expression to zero for even indices, and one part to match the coefficient. We end up with this:


a = Table[(1 - (-1)^i) (-1)^(0.5 i - 0.5)/i^2, {i, 16}]/Pi;

where the two parts are (1 - (-1)^i) and (-1)^(0.5 i - 0.5)/i^2.


Putting this into our code, we get:


enter image description here


Because the expression sometimes takes on negative values I had to apply Abs to the radii of the circle:


Circle[{A[[i]], B[[i]]}, a[[i]] // Abs]

We can find the expressions corresponding to other Fourier series in the same way.



Comments

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...