Spirographs with Mathematica

A Simple Spirograph

Imagine a wheel rolling around a second wheel that is rolling around another wheel and so on. A point on the rim of the outermost wheel will trace an interesting curve in the plane.

Let the radius and angular frequency of the (j^th) wheel be (Subscript[r, j]) and (Subscript[n, j]). The point will be at the position (∑_(j = 1)^m)(Subscript[r, j]) (e^(i (Subscript[n, j])φ)) in the complex φ-plane. The function Spirograph generates a picture of the path of the point.

Here are a few examples.

Spirograph[
      (∑_(j = 1)^5)
           ((E^(j I  φ))/(j + 1)), 
      φ];

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

Spirograph[
      (∑_(j = 1)^13) Cos[(j^2)] 
          (E^(j I  φ)), φ];

Coloring Spirographs

We color the successive line elements of a spirograph to see how the point moves as a function of time. The function ColorLine colors curve starting from red and going through yellow, green, and blue and then back to red. The object curve is extracted from the output of the function Spirograph and manipulated just like any Mathematica expression.

Here is a coloring of the second spirograph we drew above.

Show[
      Graphics[ColorLine[
          𝓈[[1, 1, 1]]]], 
      PlotRange -> All, AspectRatio -> Automatic, 
      Frame -> True, Axes -> False, FrameTicks -> None];

The next picture shows a collection of randomly generated colored spirographs.

Show[
      GraphicsArray[
        Table[Graphics[
            ColorLine[
              Spirograph[
                  (∑_(j = 1)^12) Random[Complex, {-1 - I, 1 + I}] 
                      (E^(j I φ)), 
                  φ, DisplayFunction -> Identity]
                  [[1, 1, 1]]], 
            PlotRange -> All, AspectRatio -> Automatic, 
            Frame -> True, Axes -> False, 
            FrameTicks -> None], {3}, {3}]]];

Animating a Spirograph Construction

The function SpirographAnimation generates an animation that shows the circles and the trace of a point on the outermost circle.

Here is an animation of the first spirograph that we drew.

SpirographAnimation[
      (∑_(j = 1)^5)
           ((E^(j I φ))/(j + 1)), 
      φ, 20]

A Maurer Spirograph

We can enhance our spirograph pictures using an idea of Maurer (1989).

Assume that we have a closed parametrized curve in the plane. Find the points (Subscript[p, k]) on the curve corresponding to a division of the parameter domain into m d parts, where m and d are positive integers. The d m-sided Maurer polygons are formed by joining the points (Subscript[p, k]), (Subscript[p, k + d]), (Subscript[p, k + 2  d]), ...
       , (Subscript[p, k + (m - 1) d]), (Subscript[p, k]), for k = 1, 2, ...
        , d.

Here is a spirograph picture.

Spirograph[
      (∑_(j = 1)^7)((j/6) + Sin[j]) 
          (E^(j I φ)), φ];

Here is a set of Maurer polygons for this curve.

Show[
      Graphics[{Thickness[0.0001], 
          𝓂 = 
            MaurerPolygons[
              (∑_(j = 1)^7)((j/6) + Sin[j]) 
                  (E^(j I  φ)), 
              φ, 100, 400]}], PlotRange -> All, 
      AspectRatio -> Automatic];

Again, we can color the polygons with a function ColorPolygons.

ColorPolygons[polygons_]:=
	\(With[{l = Length[polygons]}, 
		\ \ \ \ \ \ \ \ 
        MapIndexed[{Hue[#2[\([1]\)]/l]\ , #}&, polygons]]\)

Show[Graphics[
{Thickness[0.0001],ColorPolygons[𝓂]}],
PlotRange  ->  All, AspectRatio  ->  Automatic];

The function ColoredMaurerSpirograph shows the spirograph picture with one of the sets of Maurer polygons.

ColoredMaurerPolygonsSpirograph[f_, φ_, d_, m_, opts___
        ]:=Show[{Graphics[{Thickness[0.0001],ColorPolygons[MaurerPolygons[f, φ, d, m]]},PlotRange -> All,AspectRatio -> Automatic],Spirograph[f, φ, DisplayFunction -> Identity, 
                PlotStyle -> {GrayLevel[0], Thickness[0.002]}]},opts,DisplayFunction -> $DisplayFunction]

ColoredMaurerPolygonsSpirograph[(∑_(j = 1)^7)((j/6) + Sin[j]) 
            (E^(j I  φ)), 
        φ, 100, 400];

An Historical Application of Spirographs

Spirographs had an important application in the 1940s, when they were used for the "manual" solution of polynomial equations of higher degree. To understand this, let us consider the following polynomial 𝓅ℴℓ𝓎 in the variable z.

𝓅ℴℓ𝓎 = 
      (z^6) - (z^5) + 2 (z^4) - (z^3) + 2 (z^2) - z + 2

We replace the variable z by its polar form, r (e^(I φ)) , where r and φ  are the absolute value and phase or argument of z.

𝓅ℴℓ(Subscript[𝓎, 1]) = 
      𝓅ℴℓ𝓎 /. 
        z -> r (E^(I φ))

We show the spirographs for a range of values of  r.

Show[
      Table[Spirograph[𝓅ℴℓ(Subscript[𝓎, 1]), 
          φ, 
          PlotStyle -> {Thickness[0.0001], Hue[0.71 (r - 0.1)]}, 
          FrameTicks -> True, 
          PlotRange -> {{-10, 20}, {-15, 15}}, 
          DisplayFunction -> Identity], {r, 1.0, 1.2, 0.02}], 
      DisplayFunction -> $DisplayFunction];

Let us zoom to a neighborhood of the origin.

Show[%, PlotRange -> {{-1, 1}, {-1, 1}}];

Here is an even closer look.

Show[%, 
      PlotRange -> {{-(1/10), (1/10)}, {-(1/10), (1/10)}}];

These are absolute values and arguments of the zeros of the polynomial.

{Abs[#], Arg[#]}&/@
      (z /. NSolve[𝓅ℴℓ𝓎 == 0, z])

The spirograph curves corresponding to these absolute values all go through the origin.

Show[
      Spirograph[
            𝓅ℴℓ(Subscript[𝓎, 1]) /. r -> #, 
            φ, PlotStyle -> {Thickness[0.001], Hue[0.7 #1]}, 
            DisplayFunction -> Identity]&/@First/@%, 
      FrameTicks -> True, 
      PlotRange -> {{-(1/2), (1/2)}, {-(1/2), (1/2)}}, 
      DisplayFunction -> $DisplayFunction];

An analog circuit was used to vary r and the corresponding spirographs were monitored using an oscilloscope. Further analysis to determine φ led to approximations of the zeros of the polynomial.