CITE THIS NOTEBOOK: Animating smooth roll of a square wheel on a shaped road by Silvia Hao. Wolfram Community MAR 29 2023.
Take a look at sketch above. It describes an arbitrary moment during the rolling. From the kinematics view, is the "instant center of rotation". From the energy view, the square’s center of mass keeps its height, thus the potential of the square doesn’t change, means it must be in balance. Either way we arrive to the same conclusion that is perpendicular to the trajectory of (the horizontal red dash-line).
P
O
OP
O
Suppose the side length of the square is , and the equation of the questioned curve is , where parameter is the length of , which should be equal to the arc-length of P due to the slipping-less rolling. It's straightforward to see tangent vector at is parallel to , so ( is a short-form for for any )
2
r(s):(x(s),y(s))
s
CP
′
C
dr
ds
P
CP
F
dF
ds
F
-
y
x
length
CP
length
OP
x
y
Additionally, because is an arc-length parameter, we have
s
2
x
2
y
We setup the coordinate frame so the trajectory of lies on x-axis and lies on y-axis. Solving the system is a one-liner
O
′
C
In[]:=
DSolve[{sx'[s]+y'[s]==0,x'[s]^2+y'[s]^2==1,x[0]==0,y[0]==-1},{x,y},s]
Out[]=
xFunction{s},-Log-s+
1+
,yFunction{s},-2
s
1+
,xFunction{s},Log-s+2
s
1+
,yFunction{s},-2+2
s
1+
2
s
Selecting the solution with positive , we have
x
|
or
In[]:=
Block[{$Assumptions=x∈Reals},y==-Sqrt[1+s^2]/.Solve[x==ArcSinh[s],s]//FullSimplify]
Out[]=
{y+Cosh[x]0}
At last the animation:
In[]:=
ClearAll[catenaryGround,origcube,point,perp]catenaryGround=Plot[-Cosh[x],{x,-ArcSinh[1],ArcSinh[1]},PlotRange->All,AspectRatio->Automatic]//Cases[#,_Line,Infinity]&//First;origcube={{EdgeForm[GrayLevel[0.3]],FaceForm[GrayLevel[0.9]],Cuboid[{-1,-1},{1,1}]},{GrayLevel[0.3],Line[{{0,0},{0,-1}}]}};point={EdgeForm[{Hue[0.,1.,0.66],Thick}],FaceForm[GrayLevel[0.9]],Disk[{0,0},.04]};perp=Line[{{1,0},{1,1},{0,1}}];
In[]:=
ClearAll[cubeTF]cubeTF[x_]:=RotationTransform[ArcTan[1,-Sinh[x]]]/*TranslationTransform[{x,0}]
In[]:=
ClearAll[periodLen,totalPeriod]periodLen=2ArcSinh[1];totalPeriod=5;
In[]:=
DynamicModule[{period=1,xshift,xC=-(periodLen/2),x,tf,center,contact,bottom},DynamicWrapper[Deploy@Graphics[{{EdgeForm[GrayLevel[0.3]],FaceForm[GrayLevel[0.9]],Translate[FilledCurve@catenaryGround,{(#-1)periodLen,0}&/@Range[totalPeriod]]},Dynamic@GeometricTransformation[origcube,tf],{Hue[0.,1.,0.66],Dashed,InfiniteLine[{0,0},{1,0}]},{Hue[0.54,1.,0.66],Dashed,Line[Dynamic@{center,contact}]},{Hue[0.54,1.,0.66],Dynamic@GeometricTransformation[perp,RightComposition[ScalingTransform[1/8{1,1}],RotationTransform[Pi/2(<|-1->2,0->2,1->3|>@Sign[x])],TranslationTransform[center]]]},{GrayLevel[0],Dynamic@GeometricTransformation[perp,RightComposition[ScalingTransform[1/10{1,1}],RotationTransform[Pi/2(<|-1->1,0->1,1->0|>@Sign[x])],TranslationTransform[{0,-1}],tf]]},{Black,AbsoluteThickness[4],CapForm[None],Line[Dynamic@{bottom,contact}]},{Black,AbsoluteThickness[4],CapForm[None],Line@Dynamic[Function[s,{ArcSinh[s]+xshift,-Sqrt[1+s^2]}]/@N[Rescale[Rescale[Range[100]],{0,1},Sort@{0,Sinh[x]}]]]},Dynamic@Translate[point,{center,contact}],Text[Style["O",Italic,12],Dynamic[center],{0,-1}],Text[Style["P",Italic,12],Dynamic[contact],Dynamic@{-Sign[x]2,0}],Text[Style["C",Italic,12],Dynamic[bottom],Dynamic@{Sign[x]2,-1}]},ImageSize->800,PlotRange->{{-1,2totalPeriod-1}periodLen/2+{-1,1}Sqrt[2],{-1,1}Sqrt[2]},PlotRangePadding->None],xC=-Cos[2Clock[Pi,10]]//Rescale[#,{-1,1},{-1,2totalPeriod-1}periodLen/2]&;center={xC,0};period=Round[xC/periodLen]+1;xshift=(period-1)periodLen;x=xC-xshift;contact={x,-Cosh[x]}+{xshift,0};tf=cubeTF[x]/*TranslationTransform[{xshift,0}];bottom=tf@{0,-1}]]
Further resources
Further resources
◼
Stan Wagon (1999) The Ultimate Flat Tire, Math Horizons, 6:3, 14-17, https://doi.org/10.1080/10724117.1999.11975090. FULL ARTICLE.
◼
Stan Wagon (Macalester College, USA), “Roads and Wheels”, http://demonstrations.wolfram.com/RoadsAndWheels/, Wolfram Demonstrations Project, March 7, 2011.
◼
Stan Wagon (Macalester College), “Shaping a Road and Finding the Corresponding Wheel”, http://demonstrations.wolfram.com/ShapingARoadAndFindingTheCorrespondingWheel/, Wolfram Demonstrations Project, March 7 2011.