11
$\begingroup$

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?
enter image description here enter image description here

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]];
Graphics[{Polygon@pts,MapThread[Text[Style[#,13],#2+0.3Normalize[#2-Mean@pts]]&,{{"C","A","B"},pts}]},
  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]];
Graphics[{Polygon@pts,MapThread[Text[Style[#,13],#2+0.15Normalize[#2-Mean@pts]]&,
   {{"A","B","C","D","E","F"},pts}]},
  PlotRange->{{0,9},{-1,3}},Axes->1,Ticks->None,ImageSize->600]
],{n,0,6}]
$\endgroup$
5
  • $\begingroup$ 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? $\endgroup$
    – Syed
    Nov 11, 2021 at 11:11
  • $\begingroup$ @Syed The labels should keep their orientation and float is not allowed. $\endgroup$
    – matrix89
    Nov 11, 2021 at 11:22
  • 2
    $\begingroup$ related: Random polyhedra walk $\endgroup$
    – Kuba
    Nov 11, 2021 at 13:05
  • $\begingroup$ related: demonstrations.wolfram.com/… $\endgroup$
    – Greg Hurst
    Nov 11, 2021 at 13:42
  • $\begingroup$ Related: mathematica.stackexchange.com/questions/20004/… -- unrollGraphics[t] rolls (parts of) a (regular) polygon for 0 <= t < 1. $\endgroup$
    – Michael E2
    Nov 11, 2021 at 15:23

2 Answers 2

11
$\begingroup$

enter image description here

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}]
$\endgroup$
9
$\begingroup$

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]

enter image description here

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}]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.