On rolling polygons and Reuleaux polygons

Staff Picks
, , , , , ,
1

By this time, people are already familiar with Stan Wagon’s demonstration of rolling regular polygons over a piecewise catenary road, as first shown in his paper with Leon Hall.

The purpose of this post is to show a particularly compact Manipulate[] demonstration for rolling regular polygons, as well as a variation where the wheel is a Reuleaux polygon.

This hinges on two things: NDSolve[]'s ability to cope with discontinuous differential equations, and the existence of a usable polar equation in both the regular and Reuleaux polygon cases.

For the conventional regular polygon example, we can use the polar equation

r=\frac{\cos\left(\frac{\pi}{n}\right)}{\cos\left(\left(\left(\theta-\frac{\pi}{n}+\frac{\pi}{2}\right)\bmod \frac{2\pi}{n}\right) -\frac{\pi}{n}\right)}

which is a rotated modification of the formula in this Math Stack Exchange answer.

Manipulate[DynamicModule[{road, sol},
                   sol = NDSolveValue[{\[FormalTheta]'[x] ==
                                       1/ngon[n, \[FormalTheta][x]],
                                       \[FormalTheta][0] == -?/2},
                                      \[FormalTheta], {x, -1, 6}];
                   road = Plot[-ngon[n, sol[x]], {x, -1, 6}];
                   Show[road, 
                        Graphics[{{Directive[EdgeForm[GrayLevel[1/4]],
                                             ColorData[97, 3]], 
                                   Dynamic[RegularPolygon[{t, 0},
                                           {1, ?/n - ? - sol[t]}, n]]},
                                  {Directive[AbsolutePointSize[6],
                                             ColorData[97, 4]], 
                                   Point[Dynamic[{t, 0}]]}}],
                         AspectRatio -> Automatic, Axes -> None,
                         GridLines -> {None, {0}},
                         Method -> {"GridLinesInFront" -> True}, 
                         PlotRange -> {All, {-1, 1}}]],
              {{n, 4, "sides"}, 3, 12, 1}, {t, 0, 5, Animator}, 
              Initialization :> (ngon[n_Integer, ?_] :=
                                 Cos[?/n] Sec[Mod[? - ?/n + ?/2, 2 ?/n] - ?/n]), 
              SaveDefinitions -> True, SynchronousUpdating -> False]

polyroll1.png
polyroll1.png411×234 3.58 KB

Now, let us turn to the Reuleaux polygon case. I (relatively) recently derived a polar equation for the Reuleaux polygons to finally solve a longstanding problem of mine of seeing what the corresponding road for a Reuleaux polygon looks like. The polar equation is understandably a little more elaborate:

\small r=\sqrt{1+2\cos\frac{\pi}{n}+\cos^2\left(\left(\left(\theta+\frac{\pi}{2}+\frac{\pi}{n}\right)\bmod{\frac{2\pi}{n}}\right)-\frac{\pi}{n}\right)}-\cos\left(\left(\left(\theta+\frac{\pi}{2}+\frac{\pi}{n}\right)\bmod{\frac{2\pi}{n}}\right)-\frac{\pi}{n}\right)

The formula can be compacted a bit in Mathematica by using the three-argument form of Mod[].

Manipulate[DynamicModule[{road, sol, wheel},
           sol = NDSolveValue[{\[FormalTheta]'[x] == 
                               1/reuleaux[n, \[FormalTheta][x]],
                               \[FormalTheta][0] == -?/2},
                              \[FormalTheta], {x, -1, 6}];
           road = Plot[-reuleaux[n, sol[x]], {x, -1, 6}];
           wheel = First[Cases[Normal[PolarPlot[reuleaux[n, ?], {?, 0, 2 ?}, 
                         Exclusions -> None]], Line[pts_] :> pts, ?]];
           Show[road, 
                Graphics[{{Directive[EdgeForm[GrayLevel[1/4]], ColorData[97, 3]], 
                           Polygon[Dynamic[
                           AffineTransform[{RotationMatrix[-?/2 - sol[t]],
                                           {t, 0}}][wheel]]]},
                          {Directive[AbsolutePointSize[6], ColorData[97, 4]],
                           Point[Dynamic[{t, 0}]]}}], 
                AspectRatio -> Automatic, Axes -> None, GridLines -> {None, {0}}, 
                Method -> {"GridLinesInFront" -> True},
                PlotRange -> {All, {-1, 1}}]],
            {{n, 3, "sides"}, 3, 11, 2}, {t, 0, 5, Animator}, 
            Initialization :> (reuleaux[n_Integer, ?_] := 
                                Sqrt[1 + 2 Cos[?/n] +
                                     Cos[Mod[? + ?/2, 2 ?/n, -?/n]]^2] - 
                                Cos[Mod[? + ?/2, 2 ?/n, -?/n]]), 
             SaveDefinitions -> True, SynchronousUpdating -> False]

polyroll2.png
polyroll2.png411×234 4.42 KB

Here is an animation I did much earlier:

ZzERK.gif

Using the same equation, I tried to derive a closed form for the road, but got stymied when it involved the inversion of the elliptic integral of the second kind, EllipticE[].

polyroll.nb (1.73 MB)

9 Likes
2

2015-11-02_10-07-11.png

3

Very nice. Of course you know that triangles fail in the classic case because the vertex crashes into the road. Your Reuleaux method seems to not have that problem. One would have to zoom in closely to make sure the vertex happily slides into the cusp. Yes, it appears to be fine. I guess the angle is 120 degrees, not 60 like in a triangle.

Stan

5 Likes