Message Boards Message Boards

GROUPS:

On rolling polygons and Reuleaux polygons

Posted 2 months ago
591 Views
|
2 Replies
|
7 Total Likes
|

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]

rolling square


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]

rolling Reuleaux triangle

Here is an animation I did much earlier:

rolling Reuleaux triangle

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[].

Attachments:
POSTED BY: J. M.
Answer
2 Replies

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

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

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract