# Make polygon rolling along a line smoothly

I'm making an animation of a polygon rolling along the X-axis, the labels should keep their orientation and float is not allowed. Now lack of transitional status, is there an simpler way to add a rolling process?

Updated
I thought of a way, I feel that it can be further simplified, maybe you can merge two RotationTransform.

Manipulate[Module[{pts0,angles,pts1,pts},
pts0={{0,0},{-3,0},{0,4}};
angles=({π/2,ArcTan[3/4],ArcTan[4/3]}-π);
pts1=Fold[RotationTransform[angles[[Mod[#2,3,1]]],#[[Mod[2-#2,3,1]]]]@#&,pts0,Range[n]];
pts=RotationTransform[FractionalPart[n]angles[[Mod[Ceiling[n],3,1]]],pts1[[Mod[2-Ceiling[n],3,1]]]]@pts1;
Graphics[{Polygon@pts},Axes->1,Ticks->None,ImageSize->Large,PlotRange->{{-4,22},{-1,5}}]
],{n,0,5}]


Previous code

Manipulate[Module[{pts0,pts},
pts0={{0,0},{-3,0},{0,4}};
pts=Fold[RotationTransform[({π/2,ArcTan[3/4],ArcTan[4/3]}-π)[[Mod[#2,3,1]]],#[[Mod[2-#2,3,1]]]]@#&,
pts0,Range[n]];
Axes->1,Ticks->None,ImageSize->600,PlotRange->{{-4,22},{-1,5}}]
],{n,0,5}]

Manipulate[
Module[{pts0=CirclePoints[{3/2,Sqrt[3]/2},{1,4π/3},6],pts},
pts=Fold[RotationTransform[-Pi/3.,#[[Mod[#2+1,6,1]]]]@#&,pts0,Range[n]];
{{"A","B","C","D","E","F"},pts}]},
PlotRange->{{0,9},{-1,3}},Axes->1,Ticks->None,ImageSize->600]
],{n,0,6}]

• 1) Do the labels keep their orientation? 2) Do these polygons stay strictly along this line hugging it on each step or can these polygons float?
– Syed
Commented Nov 11, 2021 at 11:11
• @Syed The labels should keep their orientation and float is not allowed. Commented Nov 11, 2021 at 11:22
• related: Random polyhedra walk
– Kuba
Commented Nov 11, 2021 at 13:05
• related: demonstrations.wolfram.com/… Commented Nov 11, 2021 at 13:42
• Related: mathematica.stackexchange.com/questions/20004/… -- unrollGraphics[t] rolls (parts of) a (regular) polygon for 0 <= t < 1. Commented Nov 11, 2021 at 15:23

Here's my version. The code is pretty kludgy and could definitely be optimized; there are probably several built-in functions that I could have used but didn't know about.

The basic idea is to use $$\theta$$, the angle of rotation of the polygon, as a continuous parameter. This angle can be used to determine which corner of the polygon is currently being pivoted around, and where this corner is located.

For this code to work, the polygon's first vertex must be located at {0,0}, with one edge lying along the negative $$x$$-axis. Moreover, its points must be given in counter-clockwise order around the polygon. (It is always possible to specify a polygon in this way, of course.) This code also fails on non-convex polygons, though presumably you could fix this by using the convex hull of pts0 to determine the pivot points and distances and such.

pts0 = {{0, 0}, {0, 4}, {-3, 0}};

(* Find exterior angles between successive sides *)
angles = Table[VectorAngle @@ Take[Differences[RotateLeft[pts0, i - 2]], 2], {i, 1, Length[pts0]}]

(* Find side lengths *)
sidelengths = Table[EuclideanDistance @@ Take[RotateLeft[pts0, i - 1], 2], {i, 1, Length[pts0]}]

(* Find rotation angles at which pivot corner changes, mod 2 Pi *)
breakangles = FullSimplify[Accumulate[Prepend[angles, 0]]]

(* Find locations of each corner when it's the pivot, modulo the perimeter *)
breakdistances = Accumulate[Prepend[sidelengths, 0]]

(* Find the perimeter *)
perimeter = Last[breakdistances]

(* Create a function that determines which corner is the pivot, as a function of theta *)
pivotcorner[th_] := First[Position[Map[(Mod[th, 2 Pi] < #) &, breakangles], True]]

(* Find the pivot's location as a function of theta *)
pivotlocation[th_] := Floor[th*perimeter/(2 Pi), perimeter] +  First[Part[breakdistances, pivotcorner[th] - 1]]

(* Find locations of polygon points by translating original polygon so that pivot is at origin, rotating, and then translating resulting polygon to correct location *)
pts[th_] := RotationTransform[-th] /@ (pts0 - ConstantArray[Part[pts0, First[pivotcorner[th] - 1]], Length[pts0]])+ ConstantArray[{pivotlocation[th], 0}, Length[pts0]]

(* Render all of that in Manipulate *)
Manipulate[Graphics[{Polygon@Evaluate[pts[th]], MapThread[Text[ Style[#, 13], #2 + 0.3 Normalize[#2 - Mean@Evaluate[pts[th]]]] &, {{"C", "A", "B"}, Evaluate[pts[th]]}]},
Axes -> 1, Ticks -> None, ImageSize -> 600, PlotRange -> {{-4, 22}, {-1, 5}}],
{th, 0, 4 Pi}]


Let's start from any RandomPolygon

n = 6
p0 = RandomPolygon[{"Convex", n}][[1]]

(*make it align along x axis*)
a0 = VectorAngle[{1, 0}, p0[[2]]];
rot = RotationTransform[-a0, p0[[1]]];
p0 = Map[rot, p0];
a = PolygonAngle[Polygon[p0], "Exterior"];
Graphics[{Polygon[p0],
Text[Style[#, Red, 14], p0[[#]]] & /@ Range[n]}, ImageSize -> 200]


Now create intermediate steps such that after nr steps one side lies flat on ground.

nr = 5;(*intermediate steps between two flat configuration*)
ps = Join[{p0}, Flatten[Table[
o1 = p0[[Mod[i, n] + 1]]; a1 = -a[[Mod[i + 2, n] + 1]];
p1 = Table[ rot = RotationTransform[a1 j/nr, o1];
Map[rot, p0], {j, nr}];
p0 = p1[[-1]]; p1, {i, 4}], 1]];
np = Length[ps]

ListAnimate[ Table[Graphics[{Gray, Polygon[ps[[i]]],
Text[Style[#, Red, 14], ps[[i, #]]] & /@ Range[n], Opacity[0.1],
Polygon[#] & /@ ps}, PlotRange -> {{-0.5, 3.0}, {-0.25, 1.25}},
AspectRatio -> 1.5/3.5, ImageSize -> 500], {i, np}]]