Roulette

Author

Eric W. Weisstein
March 16, 2008

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PlaneCurves/Roulette.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Roulette.html.

©2008 Wolfram Research, Inc. except for portions noted otherwise

Code

RollingPolygon based on routines by  S. Wagon appearing in Mathematica in Action.

RollingPolygon::usage="RollingPolygon[n,x,step] gives a movie of an n-gon rolling on truncated cycloids over a length x by step size step."

RollingPolygonFrames::usage="RollingPolygonFrames[n,{t1,...,tn}] gives a movie of an n-gon rolling on truncated cycloids at steps t1, ..., tn."

polygon[n_,t_]:=Module[{loop,startpolygon,cr=Csc[Pi/n],ir=Cot[Pi/n],a},a=ir ArcSinh[1/ir];
loop=N[Floor[(t+a)/(2a)]];
startpolygon=Map[#+{0,cr}&,Map[{Re[#],Im[#]}&,cr N[Exp[I Range[-Pi/2+Pi/n,3 Pi/2+Pi/n,2 Pi/n]]]]];
Map[{t,0}+rotate[#,-(loop 2Pi/n+ArcTan[Sinh[(t-loop 2 a)/ir]]),{0,cr}]&,startpolygon]]

RollingPolygon[n_,max_,step_,curvstep_:.2,opts___]:=Module[{t,cr=Csc[Pi/n],ir=Cot[Pi/n],a,eps=.2,dots={PointSize[.0018]},plot,x,i},a=ir ArcSinh[1/ir];
plot=Table[Plot[cr-ir Cosh[(x-2a i)/ir],{x,-a+2a i,a+2a i},opts,(*PlotPoints->2,MaxBend->500.,PlotDivision->2.1,*)DisplayFunction->Identity,PlotStyle->Thickness[.01]],{i,0,max/2+1}];
Table[newpolygon=polygon[n,t];
AppendTo[dots,Point[newpolygon[[n]]]];
Show[Graphics[{{GrayLevel[.75],EdgeForm[],Polygon[newpolygon]},Line[newpolygon],{PointSize[.02],Point[{t,cr}],Point[newpolygon[[n]]]},(*dots,*)Line[Append[Table[polygon[n,x][[-2]],{x,0,t,curvstep}],polygon[n,t][[-2]]]],{Dashing[{.02,.02}],Line[{{0,cr},{max,cr}}]}}],plot,PlotRange->{{-cr-eps,max+cr+eps},{-.2-eps,2cr+eps}},AspectRatio->Automatic,DisplayFunction->$DisplayFunction,Ticks->None,Axes->None],{t,0,max,step}]]

RollingPolygonFrames[n_,t_List,dotstep_:.2]:=Module[{cr=Csc[Pi/n],ir=Cot[Pi/n],a,eps=.2,plot,x,i},a=ir ArcSinh[1/ir];
plot=Table[Plot[cr-ir Cosh[(x-2a i)/ir],{x,-a+2a i,a+2a i},DisplayFunction->Identity,PlotStyle->Thickness[.01]],{i,0,Max[t]/2+1}];
Show[Graphics[{{GrayLevel[.75],EdgeForm[],Polygon/@Table[polygon[n,t[[i]]],{i,Length[t]}]},Line/@Table[polygon[n,t[[i]]],{i,Length[t]}],{PointSize[.02],Point/@Table[polygon[n,t[[i]]][[-2]],{i,Length[t]}],Point/@Table[{t[[i]],cr},{i,Length[t]}]},Line[Table[polygon[n,x][[-2]],{x,Min[t],Max[t],dotstep}]],{Dashing[{.02,.02}],Line[{{Min[t],cr},{Max[t],cr}}]}}],plot,PlotRange->{{-cr-eps,Max[t]+cr+eps},{-.2-eps,2 cr+eps}},AspectRatio->Automatic,DisplayFunction->$DisplayFunction,Ticks->None,Axes->None]]

Triangle

RollingPolygonFrames[3,Table[2.6i,{i,0,4}],.2]

Animation

<<Utilities`GIF`;

Export[gifs<>"roll3gon.gif",RollingPolygon[3,9,.3,.1,PlotRange->All]]

Square

RollingPolygonFrames[4,Table[3i,{i,0,3}],.2]

Animation

<<Utilities`GIF`;

Export[gifs<>"roll4gon.gif",RollingPolygon[4,9,.3,.1,PlotRange->All]]

Pentagon

RollingPolygonFrames[5,Table[3.3i,{i,0,4}],.2]

Animation

<<Utilities`GIF`;

Export[gifs<>"roll5gon.gif",RollingPolygon[5,10,.4,.1,PlotRange->All]]

Hexagon

RollingPolygonFrames[6,Table[4.3i,{i,0,4}],.2]

Animation

<<Utilities`GIF`;

Export[gifs<>"roll6gon.gif",RollingPolygon[6,15,.8,.1,PlotRange->All]]