From Spirograph to Fourier

Ivan Cnop
Vrije universiteit Brussel
icnop@vub.ac.be

Robots with a single drive

Problem

A robot has an arm of length   length1  moving around a fixed point, and at the end of this arm a second  arm  length    length2   is fixed by some gears , making an angle which is a multiple, with a given constant  c  (times) the original angle  t  . What is the curve described by the end of the second  arm?
Here are parametric equations when we use here the representation of the point by an arrow which sticks in the direction of the angle (denoted  (e^( i t ))in formulas. Adding two such arrows we obtain

position[t_]:=length1 (E^(I t))+length2  (E^(I c t))

for instance

length1 = 1;
length2 =  .5 ;

Remark: students can learn to work with positions using ArgColors which colors  angles  according to Hues. 
This is done in a different text introducing the discrete Fourier Transform.

The Cardioid: doubling the  angle for the second arm

c = 2;

To realise plots we have to compute the real and imaginary part of the position to obtain the coordinates of the position.
Here is the curve that is given by a ParametricPlot:

Clear[move]

move[until_]:=ParametricPlot[{Re[position[t]], Im[position[t]]},{t, 0, until}
,AspectRatio -> Automatic
	,PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}}
	,PlotStyle -> Hue[0]]

move[π]

move[2 π]

Here is  an animation showing how the movement runs in time when   t   is the time parameter:

Do[move[until],{until,π/36, π,π/36}]

This animation gives an idea of the velocity of the movement. This shows that the movement is not very efficient: if the robot had to move a bottle from right to left, this should be very slow in the end, and moreover the bottle would be broken by the brisk start. We will see more efficient movements below.

Analysis of the movement

This part may be skipped for students that are not yet familiar with elementary physics.

First derivatives and velocities

Clear[x, y]; x[t_] = ComplexExpand[Re[position[t]]]; 
    y[t_] = ComplexExpand[Im[position[t]]]

ParametricPlot[{x'[t], y'[t]},{t, 0, π}
,AspectRatio -> Automatic
	,PlotRange -> {{-2, 2}, {-2, 2}}]

endpoints = 
        Table[{{x[t], y[t]}, {x[t] + x'[t], y[t] + y'[t]}}, {t, 
            0, π, π/20}];

tangent = Map[Line, endpoints];

Show[{Graphics[tangent], move[π]}, 
      AspectRatio -> Automatic]

Second derivative and acceleration

pulls=Table[{{x[t], y[t]}, {x[t] + x''[t], 
                y[t] + y''[t]}},{t,0, Pi,Pi/20}];

force = Map[Line, pulls];

Show[{Graphics[force],move[Pi]},AspectRatio -> Automatic]

The force, which is radial in the beginning, remains rather big and pulls against the direction of movement (braking) near the endpoint.
It is possible to replace the segments by arrows 
COMMENT: is it by chance that endpoints of acceleration vectors seem to lie on a circle?
(It is indeed possible to compute in Mathematica all parametric movements in the plane for which this is true).

Exercise

This example should be repeated for many values of length2 and c. 
A negative value of length2 will mirror  the cardioid. 
Changing the value of   c  (try  c = 3 and c = 4)  gives very different shapes.

The ellipse: opposite angle for the second arm

c = -1;

length1 = 1;
length2 =  .6 ;

Clear[x, y]; x[t_] = ComplexExpand[Re[position[t]]]; 
    y[t_] = ComplexExpand[Im[position[t]]]

move[until_]:=ParametricPlot[{x[t], y[t]},{t, 0, until}
,AspectRatio -> Automatic
	,PlotRange -> {{-2, 2}, {-2, 2}}
	,PlotStyle -> Hue[0]]

move[π]

COMMENT: it is an ellipse! It is maybe the best way to represent an ellipse

Here is  an animation

Do[move[until],{until,Pi/20, Pi,Pi/20}]

COMMENT: it is possible to investigate velocities. 
This shows that the movement is  very efficient: if the robot had to move a bottle, this will be very careful in the beginning , with top speed near the middle and gradually decreasing afterwards.

First derivatives and velocities

COMMENT: this is a good occasion for using coloured arrows or points (ArgColors)

ParametricPlot[{x'[t], y'[t]},{t, 0,  π}
,AspectRatio -> Automatic
	,PlotRange -> {{-2, 2}, {-2, 2}}]

endpoints = 
        Table[{{x[t], y[t]}, {x[t] + x'[t], y[t] + y'[t]}}, {t, 
            0, π, π/20}];

tangent = Map[Line, endpoints];

Show[{Graphics[tangent], move[Pi]}, 
      AspectRatio -> Automatic]

Here is the absolute velocity

Plot[(Sqrt[x'[t]^2 + y'[t]^2]), {t, 0, π},  
      PlotRange -> {0, 2}]

Second derivative and acceleration

pulls = 
        Table[{{x[t], y[t]}, {x[t] + x''[t], 
              y[t] + y''[t]}}, {t, 0, π, π/20}];

force = Map[Line, pulls];

Show[{Graphics[force],move[π]},AspectRatio -> Automatic]

The force remains rather big and pulls against the direction of movement (braking) near the endpoint.
COMMENT: is it by chance that  acceleration vectors seem to share the same endpoint?

Here is the absolute force: it looks like the stretching of an elastic band

Plot[(Sqrt[x''[t]^2 + y''[t]^2]), {t, 0, π},  
      PlotRange -> {0, 2}]

COMMENT: This experiment should be repeated for many values of length2 to check these conclusions.

Focal Points

It was already known in the XVIIth century that this is a tool for drawing an ellipse. The large axis is twice the sum of the arm sections and its small axis is twice the positive difference of the arm sections. We do not immediately find the focal points as in the construction of an ellipse with two pins and a piece of rope. The Pythagorean theorem yields that focal points are at  –2  and  +2  if the product of the arm section lengths is 1. Therefore the following are confocal ellipses:

a =. ;
c = -1;
length1 = a;
length2 = 1/a ;

Clear[x, y]; x[t_] := ComplexExpand[Re[position[t]]]; 
    y[t_] := ComplexExpand[Im[position[t]]]

move[until_]:=ParametricPlot[{x[t], y[t]},{t, 0, until}
,AspectRatio -> Automatic
	,PlotRange -> {{-3, 3}, {-3, 3}}
	,PlotStyle -> Hue[0]]

Do[move[2 π], {a,  .4, 3,  .2}]

Animate this sequence to see how they look

REMARK: among these ellipses there is the degenerate case of the line segment [-2,2] .

Showing arms

What follows is valid for many multipliers  c . This requires new definitions in our parametric plots.

Clear[move]

move[c_]:=ParametricPlot[{x[t, c], y[t, c]},{t, 0,  2 Pi}
,AspectRatio -> Automatic
	,PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}}
	,PlotStyle -> Hue[0]]

c =. ; a =. ;

Clear[x, y]

x[t_, c_] := length1 Cos[t] + length2  Cos[c t]
y[t_, c_] := length1 Sin[t] + length2  Sin[c t]

arm1points = 
        Table[{{0, 0}, {length1 Cos[t], length1 Sin[t]}}, {t, 0, 2  Pi, 
            Pi/20}];

It is posible to make a graphical selection of lengths in an empty graphic

Plot[0, {t, 0, 2}, PlotRange -> {0, 2}]

{0.999724, 0.44566}

{length1, length2} = %;

arm1 = Map[Line, arm1points];

arm2points[c_] := 
      Table[{{length1 Cos[t], length1 Sin[t]}, {x[t, c], y[t, c]}}, {t, 0, 
          2  Pi, Pi/20}]

arm2[c_] := Map[Line, arm2points[c]]

Show[{Graphics[arm1], Graphics[arm2[2]], move[2]}, 
      AspectRatio -> Automatic]

Show[{Graphics[arm1],Graphics[arm2[-1]],move[-1]},AspectRatio -> Automatic]

COMMENT: for adding drama  in the next pictures, it is better to decrease  c  from  2  to  -1.
Haven't you all seen these Japanese multilink robots making weird movements? They seem to move different arms in opposite directions, and amazingly enough these movements are the most efficient (accelerating gradually , while not breaking any  bottles and reaching farthest).
Would be nice to add a piece of video footage from a Fanuc factory!

An overview of curves

The next graphics present a number of cycloids. 
Among these are the deltoid and the asteroid from the clubs card series.

Show[GraphicsArray[Table[
		Show[{Graphics[arm1], Graphics[arm2[c]], move[c]}, 
                  AspectRatio -> Automatic]
,{c,-4,4,1}]],PlotLabel -> StyleForm["summary", TextStyle]]

COMMENT: we now start making complete turns and cycloids.

Sensation on the "Calypso"

This hinged arm is also the main mechanism in many theme park attractions.

c =.

x[t_, c_] := length1 Cos[t] + length2  Cos[c t]
y[t_, c_] := length1 Sin[t] + length2  Sin[c t]

Clear[move, arm1, arm2]

move[c_]:=ParametricPlot[{x[t, c], y[t, c]},{t, 0,  2 Pi}
,AspectRatio -> Automatic
	,PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}}
	,PlotStyle -> Hue[0]]

arm1points = 
        Table[{{0, 0}, {length1 Cos[t], length1 Sin[t]}}, {t, 0, 2  Pi, 
            Pi/20}];

arm1 = Map[Line, arm1points];

Show[{Graphics[arm1], move[-3]}, 
      AspectRatio -> Automatic]

arm2points[c_] := 
      Table[{{length1 Cos[t], length1 Sin[t]}, {x[t, c], y[t, c]}}, {t, 0, 
          2  Pi, Pi/20}]

arm2[c_] := Map[Line, arm2points[c]]

Show[{Graphics[arm1], Graphics[arm2[-3]], move[-3]}, 
      AspectRatio -> Automatic]

COMMENT: increase partition somewhat for better viewing.
Repeat velocity and acceleration drawings for these examples.
Ask questions about rolling a disk inside a circle.
Here are some other cycloids

Show[{Graphics[arm1],Graphics[arm2[-7]],move[-7]},AspectRatio -> Automatic]

Show[{Graphics[arm1], Graphics[arm2[-2]], move[-2]}, 
      AspectRatio -> Automatic]

COMMENT: This is a small area solution to the turning needle (of length = 2 length1 )  problem. Interesting to make pictures for different length2 .
Don't tell students yet that it is possible to turn a needle in zero area: they are not ready for this.

Spirograph:  Fourier's toy

The classic spirograph

Everybody nows someone who, as a child, used to play with a spirograph. It was very a simple toy which was very successful some time ago. It consisted of plastic disks which could turn around and inside each other, while the crank-shaped rims kept in contact. The basic circle movement allowed  drawing nice cycloid shapes by putting a pencil through one of the many holes. Since these depend on the ratio of dents on the gear wheels, what we obtain are the above drawings when   c  is replaced by a rational number. We cannot expect to have a closed curve for one turn on the main arm (wheel) and we have to increase the number of turns according to the denominator of the simplified fraction.

c = - 2/5;

length1 = 1;
length2 =  .6 ;

Clear[x, y]; x[t_] = ComplexExpand[Re[position[t]]]; 
    y[t_] = ComplexExpand[Im[position[t]]]

move[until_]:=ParametricPlot[{x[t], y[t]},{t, 0, until}
,AspectRatio -> Automatic
	,PlotRange -> {{-2, 2}, {-2, 2}}
	,PlotStyle -> Hue[0]]

move[π]

move[10 π]

Non-rational gear ratios

In the case the ratio   c  is not a rational number,  such curves do not close after a finite number of turns.

c = - 1/E;

length1 = 1;
length2 =  .6 ;

Clear[x, y]; x[t_] = ComplexExpand[Re[position[t]]]; 
    y[t_] = ComplexExpand[Im[position[t]]]

move[until_]:=ParametricPlot[{x[t], y[t]},{t, 0, until}
,AspectRatio -> Automatic
	,PlotRange -> {{-2, 2}, {-2, 2}}
	,PlotStyle -> Hue[0]]

move[4  π]

move[40  π]

move[100  π]

For very long parametric plots we have to refine the plotting options to obtain a smooth looking polygonal approximation of the curve

Multiply hinged robot arms.

Adding more sections to the robot arm, each with its own gear ratio, will generate other curves. Gear ratios that are natural numbers correspond to polynomial mappings with coefficients that are the respective arm section lengths. If we allow for negative  (whole number) gear ratios as in the ellipse we have rational functions (up to a limited negative power). For a CAS this extension is no problem even if the coefficients are negative. It gets increasingly difficult however to manufacture toy models in hardware because of friction and strain and it is no longer possible to sketch models using three or more plastic Spirograph disks. Rational gear ratios will give curves which, just as in the Spirograph case, close only after a sufficiently large number of turns. Irrational gear ratios will never close and may even fill parts of the plane if we continue running the main angle around the unit circle. Let us therefore stick to ratios that are whole numbers. A list-oriented program for making such models is in [H.Uscka:"Complex Polynomials"(in Dutch), Exploot Project, 2001] and this author refers to the web-site of Frank Farris for symmetry properties of the resulting pictures. For now we redefine the motion for polynomial images to introduce Fourier series, and we will return to rational function images later to develop other applications.

Definition of movement

On a computer screen we can simulate this by letting circles turn while the midpoint of each following circle turns on the circumference of the previous one. The animation which shows this behaviour is in the  Mathematica   Spirograph demo notebook. We take the basic function from that notebook and let circles turn from  - π  to  +π  , in order to have a starting interval symmetric around the origin:

Remark: All  functions considered are periodic and therefore it is sufficient to plot them on an interval  [0,2 π]  or  [-π,π] . 
(For applications where one has to consider different periods it will be useful to modify the interval to [-2π,2π]  or [-kπ,kπ].)

To see how the movement occurs without using animations (to reduce memory use), it is possible to plot the movement in 3 dimensions in coordinates {t,x,y}: here   t   is the parameter which gives the rotation of the basic circle. The y-axis remains vertical by putting the extra axis first!

We use a realtime moving in three dimensions to be able view the obtained 3D graphics from all viewpoints by using the mouse:

<< RealTime3D`

𝓈 = 
        spirograph[(∑_(j = 1)^2) 1/
                j (E^(j I t)), t];

𝓈 = 
        spirograph[(∑_(j = 1)^5) (E^(j I t)), t];

s3 = 
        spirograph3D[(∑_(j = 1)^5) (E^(j I t)), t];

The projection on the  {φ,y}-plane gives the imaginary part of the moving point:
In Default3D` we put the ViewPoint far away to reduce perspective distortion)

Show[s3, ViewPoint -> {0, -100, 0}, Axes -> True]

and a projection on the  {φ,x}-plane gives the real part of the moving point:

Show[s3, ViewPoint -> {0, 0, 100}, Axes -> True]

In these pictures, front and back of the Box nearly coincide in a thick 2 pixel line.

Polynomials with arbitrary coefficients.

Clear[powers, f, coeffList]

A polynomial with arbitrary (real or complex) coefficients can be written by making the scalar (Dot) product of the coefficients with a list of powers. In the rest of this notebook we concentrate on real coefficients. In what follows we also do not write constant terms,  since adding a constant will only translate the final picture. As in Mathematica, it is advised to write lowest degree coefficients first to allow for polynomials of arbitrary degree:

powers[coeffList_, z_] :=  z^Range[Length[coeffList]]

f[coeffList_, t_] := (coeffList .  powers[coeffList, z]) /. 
        z -> E^(I t)

The use of E^(I φ) can be avoided by slightly changing the spirograph definition, or hiding the definition of the polynomials in cells with white text.
It is possible to use location [distance=1, angle] for students with little or no trig experience. Tell them that z is the notation for location, and remind them of the convention that powers of z are made up by multiplying angles, just as multiplication of locations is done by adding the corresponding angles.

Example

The following does have a negative coefficient, which means that the corresponding "arm" is starting backward

coeffList = {1,  .3,  .5, - .5, 1}

f[%, t]

𝓈 = spirograph[%, t];

s3 = spirograph3D[%%, t];

Example

coeffList = 1/Range[6]

f[%, t]

𝓈 = spirograph[%, t];

s3 = spirograph3D[%%, t];

Show[s3, ViewPoint -> {0, -100, 0}, Axes -> True]

Show[s3, ViewPoint -> {0, 0, 100}, Axes -> True]

A first result

Assignment: in all these examples, the top view is an odd function, while the front view is even.Is it a coincidence?
		
For students with trigonometric experience: try to prove this.

Example

coeffList = 1/Range[11]

f[%, t]

𝓈 = spirograph[%, t];

s3 = spirograph3D[%%, t];

Example

coeffList = 1/Range[51];

f[%, t];

𝓈 = spirograph[%, t, PlotPoints -> 500];

s3 = spirograph3D[%%, t, PlotPoints -> 500];

We see in these examples that it is possible to approximate functions that are not easily approximated by Taylor polynomials.
Periodic functions deserve a separate treatment.

In practice, we will see that all periodic continuous functions can be approximated by these views. We first have to split a periodic function into even and odd functions.

Even-Odd decomposition

Given a function f , it is possible to split f  into an even and an odd part by

even[f_, x_] := (f[x] + f[-x])/2

odd[f_, x_] := f[x] - even[f, x]

Clear[k]

k[x_] := x^2 + 1 - x

Plot[{even[k, x], odd[k, x]}, {x, -1, 1}]

Plot[even[k, x] + odd[k, x], {x, -1, 1}]

Plot[k[x], {x, -1, 1}]

More experiments

Repeat the spirograph construction with the following sequences of coefficients and check the result against a table of Fourier Series: 
	(1/(n n - 1))		
	1,0,1/3,0,1/5,0,....    
	1,0, 1/9,0,1/25,0,....    
	1,-1/2,1/3,-1/4,1/5,..... 
	0,1/3,0,1/3.5,0,1/5.7,0,...
	1,-1/4,1/9,....
	0,1,0, 1/4,0,1/9,0,....    
	1,-1/8,1/27,.....
	1,0,1/27,0,1/125,.....