8
$\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$
6
10
$\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$
8
$\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.