Fun with Maths - Wellington Boot Epicycles

Karen Henry Educational Epicycles Fun Maths Science Wellington Boots Wolfram Alpha

Here are 10 steps to create a Wellington Boot from rotating circles (epicycles).

Ref 1: https://youtube.com/watch?v=qS4H6PEcCCA by Mathologer (recommend to subscribe) - Explanation of the maths

Ref 2: https://mathematica.stackexchange.com/questions/171755/how-can-i-draw-a-homer-with-epicycloids by anderstood for the code

Ref 3: Code file - if you need the code

Ref 4: The welly image

1) Create an account (14-day free trial available) at https://mathematica.wolframcloud.com

2) Create a new Wolfram notebook (File -> New Notebook)

Paste the following code into the top part of the notebook (takes a few seconds for Wolfram to recognise it):

img = Import["https://cdn.shopify.com/s/files/1/0001/1319/files/wellington-boot-black-and-white.gif?9529291750893159073"];
img = Binarize[img~ColorConvert~"Grayscale"];
img = ImageResize[img,100];
img = Blur[img,3];
pts = DeleteDuplicates@
   Cases[Normal@
      ListContourPlot[Reverse@ImageData[img],
       Contours -> {0.5}], _Line, -1][[1, 1]];
center = Mean@MinMax[pts] & /@ Transpose@pts;
pts = # - center & /@ pts[[;; ;; 20]];
wellyPlot = ListPlot[pts, AspectRatio -> Automatic]

Note: You may need to adjust the ImageResize parameter above to a lower or higher number depending on the size of the input image.

 3) In the top-right corner click "Evaluate cell" (see red arrow in the diagram below)

Wolfram Wellington Boot Science

4) Wait a few seconds for the code to evaluate

Welly Plot

5) Paste the next block of code into the notebook below the plot

SetAttributes[toPt, Listable]
toPt[z_] := ComplexExpand[{Re@z, Im@z}] // Chop;
cf = Compile[{{z, _Complex, 1}},
    Module[{n = Length@z},
1/n*Table[Sum[z[[k]]*Exp[-I*i*k*2 Pi/n], {k, 1, n}], {i, -m, m}]]];
z = pts[[All, 1]] + I*pts[[All, 2]];
m = 18;
cn = cf[z];
{f[t_], g[t_]} =
Sum[cn[[j]]*Exp[I*(j - m - 1)*t], {j, 1, 2 m + 1}] // toPt;
ParametricPlot[{f[t], g[t]}, {t, 0, 2 Pi}, AspectRatio -> Automatic]

Note: You may need to adjust the value of m above depending on the size of the image.

6) Click evaluate on the code

7) Wait for it to run

Wellington Epicycles

8) Paste the last code to animate the circles:

r = Abs /@ cn;
theta = Arg /@ cn;
index = {m + 1}~Join~
   Riffle[Range[m + 2, 2 m + 1], Reverse[Range[1, m]]];
p[t_] = Accumulate@Table[cn[[j]]*Exp[I*(j - m - 1)*t], {j, index}] // toPt;
circles[t_] =
  Table[Circle[p[t][[i]], r[[index[[i]]]]], {i, 1, 2 m + 1}];

anims = ParallelTable[
   ParametricPlot[{f[s], g[s]}, {s, 0, t}, AspectRatio -> Automatic,
     Epilog -> {circles[t][[2 ;;]], Line[p[t]], Point[p[t]]},
PlotRange -> {{-100, 50}, {-70, 60}}, ImageSize -> 400], {t, Subdivide[0.1, 4 Pi, 20]}];
ListAnimate@anims


Note: You may need to adjust the PlotRange x,y and x,y values to centre the plot.

9) And the result: 

10) Let us know how you get along.



Older Post


Leave a comment