12
$\begingroup$

enter image description here
The vertex A,B of the square ABCD with side length $\sqrt{2}$ is on the circle with radius $\sqrt{2}$, vertex C,D is inside the circle, roll the square ABCD along the inside of the circle counterclockwise without sliding.
My code is already working, but I believe he can be more concise

Clear["`*"];
p0 = N @ {{-√2/2, -√6/2}, {√2/2, -√6/2}, {√2/2, √2-√6/2}, {-√2/2, √2-√6/2}};
p1[t_] := RotationTransform[t,p0[[1]]][p0];
p2[t_] := RotationTransform[t,p1[π/6][[4]]][p1[π/6]];
p3[t_] := RotationTransform[t,p2[π/6][[3]]][p2[π/6]];
p4[t_] := RotationTransform[t,p3[π/6][[2]]][p3[π/6]];
p5[t_] := RotationTransform[t,p4[π/6][[1]]][p4[π/6]];
p6[t_] := RotationTransform[t,p5[π/6][[4]]][p5[π/6]];

Manipulate[
  Graphics[
    {Circle[{0, 0}, Sqrt[2]], EdgeForm[Black], Opacity[0.1],
     Polygon[
       Which[
         t < π/6, p1[t], 
         t < 2π/6, p2[t-π/6], 
         t < 3π/6, p3[t-2π/6], 
         t < 4π/6, p4[t-3π/6], 
         t < 5π/6, p5[t-4π/6], 
         True, p6[t-5π/6]]]},
    PlotRange -> 2], 
  {t, 0, 6π/6}]

Some attempts, but lacks the rotation process

With[{p0=N@{{-√2/2,-√6/2},{√2/2,-√6/2},{√2/2,√2-√6/2},{-√2/2,√2-√6/2}}},
  Manipulate[With[{pts=Fold[RotationTransform[π/6,#[[-Mod[#2,4,1]]]]@#&,p0,Range[0,i]]},
    Graphics[{Circle[{0,0},Sqrt[2]],{EdgeForm[Black],Opacity[0.1],Polygon@pts}},
      PlotRange->2]],{i,0,5}]]

Do you have a better way?

Tips that may be useful
Which[t < π/6, t, t < (2 π)/6, t - π/6, t < (3 π)/6, t - (2 π)/6, t < (4 π)/6, t - (3 π)/6, t < (5 π)/6, t - (4 π)/6, True, t - (5 π)/6] == Mod[t, Pi/6]

$\endgroup$
1
  • $\begingroup$ Just transform a Rectangle---not each point that defines one. $\endgroup$ Jan 5, 2021 at 18:48

3 Answers 3

17
$\begingroup$

EDIT 1. Fixed kernel crashing. The problem was WhenEvent choking, because it was continually checking whether the current pivot (which lies exactly on the bounding circle) goes outside the bounding circle.

EDIT 2. Here is a port to GNU Octave: https://github.com/yawnoc/tumbling-polygon


System of ODEs in the complex plane

For a completely different take, observe that rigid rotation of the $n$th vertex $z_n$ around a pivot $p$ can be expressed as the differential equation

$$\frac{\mathrm{d}z_n}{\mathrm{d}t} = \mathrm{i} \,(z_n - p),$$

where $\mathrm{i} = \sqrt{-1}$, and we have scaled out the angular velocity. This is because the instantaneous velocity is (1) at right angles to the displacement vector $z_n - p$, and (2) proportional to the distance $|z_n - p|$. (Remember multiplication by $\mathrm{i}$ effects a 90-degree rotation.) If the vertex $z_n$ happens to coincide with the pivot location $p$, this nicely reduces to $\mathrm{d}z_n / \mathrm{d}t = 0$.

So we solve a system of such ODEs in $(z_1, z_2, z_3, z_4, p)$, where we handle the collision with the bounding circle $|z| = \sqrt{2}$ using WhenEvent; if $|z_n| > \sqrt{2}$, we set $p$ to $z_n$.

ClearAll["Global`*"];

vertexInitialPositions = Complex @@@ N @ {
  {-Sqrt[2]/2, -Sqrt[6]/2},
  {Sqrt[2]/2, -Sqrt[6]/2},
  {Sqrt[2]/2, Sqrt[2] - Sqrt[6]/2},
  {-Sqrt[2]/2, Sqrt[2] - Sqrt[6]/2},
  Nothing
};
vertexCount = Length[vertexInitialPositions];
vertexRotationEquations =
  Table[z[i]'[t] == I (z[i][t] - p[t]), {i, vertexCount}];

pivotFixtureEquation = p'[t] == 0;

vertexInitialConditions =
  Table[z[i][0] == vertexInitialPositions[[i]], {i, vertexCount}];

pivotInitialCondition = p[0] == First[vertexInitialPositions];
boundingRadius = Sqrt[2];
collisionHandling =
  Table[
    whenEventDummy[
      (* If this vertex isn't pivot AND goes outside bounding circle *)
      z[i][t] != p[t] && Abs @ z[i][t] > boundingRadius,
      (* Set the pivot to this vertex *)
      p[t] -> z[i][t]
    ]
    , {i, vertexCount}
  ] /. {whenEventDummy -> WhenEvent};
dependentVariables = Table[z[i], {i, vertexCount}] // Append[p];
tMax = Pi;
trajectories =
  NDSolveValue[
    Flatten @ {
      vertexRotationEquations, pivotFixtureEquation,
      vertexInitialConditions, pivotInitialCondition,
      collisionHandling
    },
    dependentVariables,
    {t, 0, tMax}
  ];
vertexRealTrajectories[t_] :=
  Most[trajectories][t] // Through // ReIm // Evaluate;
Manipulate[
  Show[
    Graphics @ Circle[{0, 0}, boundingRadius],
    Graphics @ Polygon @ vertexRealTrajectories[tCurrent],
    If[tCurrent == 0, {},
      ParametricPlot[
        vertexRealTrajectories[t]
        , {t, 0, tCurrent}
      ]
    ]
    , ImageSize -> 240
  ]
  , {tCurrent, 0, tMax}
]

Tumbling square animation

The nice thing about this method is that it generalises to any polygon. Also the initial pivot need not start on the bounding circle (and in fact need not be any of the vertices).

Tumbling quadrilateral animation (not a square)

$\endgroup$
1
$\begingroup$

At first we need to rotate the first edge around the first point.We use NMinimize to find such minimal angle.

We ordering the points of polygon by clockwise,and rotate it by anticlockwise,so here we use RotateLeft to change the order of points.

pts = {{1, 0}, {-0.2, -0.1}, {-0.1, 0.6}, {0.2, 0.8}, {Cos[1], 
    Sin[1]}};
rotaAngle[p_, center_] := 
  Module[{θ}, 
   First@NMinimize[{θ, 
      Norm@RotationTransform[θ, center][p] == 1, θ > 
       0}, {θ}]];
f[pts_] := Module[{θ, center},
   θ = rotaAngle[pts[[2]], pts[[1]]];
   center = pts[[1]];
   RotateLeft[RotationTransform[θ, center] /@ pts, 1]];
polygon = NestList[f, pts, 20];
Manipulate[
 Graphics[{Circle[], FaceForm[], EdgeForm[Red], 
   Polygon[polygon[[n]]]}], {n, 1, 20, 1}]

Here just a temporary workaround,I need time to find the way to rotate the polygon Independently.

Edit

Test another convex region.

reg = ImplicitRegion[x^2/4 + y^2/3 <=  1 , {x, y}];
pts = {{2, 0}, {1, -0.2}, {1, 0.3}, {1.3, 0.6}, {1.5, 0.5}};
rotaAngle[pts_] := 
  Module[{θ}, 
   First@NMaximize[{θ, 
      AllTrue[RotationTransform[θ, First[pts]] /@ Rest[pts], 
       Element[#, reg] &], π > θ > 0}, {θ}, 
     Method -> Automatic]];
f[pts_] := Module[{θ, center}, θ = rotaAngle[pts];
   center = pts[[1]];
   RotateLeft[RotationTransform[θ, center] /@ pts, 1]];
polygon = NestList[f, pts, 20];
regionplot = 
  RegionPlot[reg, Frame -> False, PlotStyle -> {Cyan, Opacity[0.2]}, 
   BoundaryStyle -> Green, AspectRatio -> Automatic];
Manipulate[
 Show[regionplot, 
  Graphics[{FaceForm[], EdgeForm[Red], Polygon[polygon[[n]]]}]], {n, 
  1, 20, 1}]
$\endgroup$
1
  • $\begingroup$ rotaAngle[p_, center_] := Module[{θ}, First@NMaximize[{θ, RotationTransform[θ, center][p] ∈ reg, π > θ > 0}, {θ}]]; $\endgroup$
    – cvgmt
    Jan 9, 2021 at 0:14
0
$\begingroup$

A start at a better way:

Graphics[
 GeometricTransformation[Rectangle[],
  RotationTransform[30 Degree, {0, 0}]]]

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.