8
$\begingroup$

enter image description here
Reference link: https://www.geogebra.org/m/RHYH3UQ8 , https://www.geogebra.org/m/xkzsqcyx , https://www.netpad.net.cn/svg.html#posts/55789

I want to generate an rotating squares animation like this, my code only workd for 3×3 squares, how can I expand to more squares ( (2n-1) × (2n-1) )?

pts = {{0, 0}, {1, 0}, {1, 1}, {0, 1}};

Manipulate[Graphics[{
   EdgeForm[Gray], LightRed,
   RotationTransform[θ + Pi/2, #]@pts & /@ pts // Polygon,

   LightGreen, Polygon[pts],
   TranslationTransform[RotationTransform[θ + Pi/2, #2]@# - #]@pts & @@@
     Partition[pts, 2, 1, 1] // Polygon
   }, PlotRange -> {{-2, 3}, {-2, 3}}], {θ, 0, Pi}]

enter image description here

Build a chessboard without rotating:

Graphics[{EdgeForm[Gray],
  Table[{If[Mod[i+j, 2]==0,LightRed,LightGreen],Rectangle[{i,j}]},{i,5},{j,5}]} ]

or

ArrayPlot[Mod[Array[Plus,{5,5}],2],ColorRules->{0->LightRed,1->LightGreen},Mesh->All]

enter image description here

$\endgroup$
12
+100
$\begingroup$

I made a similar animation once with plusses:

enter image description here

I changed the shape of the plus to a square. Here is the code:

\[CurlyPhi] = Tan[1/3.];
Clear[DrawPlus, MakeScene]
DrawPlus[p : {x_, y_}, \[Theta]_] := Module[{line},
  (*line=Polygon[{{1,1},{3,1},{3,-1},{1,-1},{1,-3},{-1,-3},{-1,-1},{-3,-\
1},{-3,1},{-1,1},{-1,3},{1,3},{1,1}}];*)
  line = Polygon[{{3, 1}, {1, -3}, {-3, -1}, {-1, 3}}];

  line = GeometricTransformation[line, RotationMatrix[\[Theta]]];
  GeometricTransformation[line, TranslationTransform[p]]
  ]
MakeScene[\[Alpha]_] := Module[{p, q, \[Theta] = \[Pi] \[Alpha], gr},
  p = {1., -3.} + 
    Sqrt[10] {Cos[\[Theta] - \[CurlyPhi]], -Sin[\[Theta] - \
\[CurlyPhi]]};
  q = {3., 1.} + 
    Sqrt[10] {Sin[\[Theta] - \[CurlyPhi]], 
      Cos[\[Theta] - \[CurlyPhi]]};
  gr = Flatten[
    Table[DrawPlus[i p + j q, If[EvenQ[i + j], 0, -\[Theta]]], {i, -3,
       3}, {j, -3, 3}], 1];
  (*gr=GeometricTransformation[gr,RotationMatrix[\[Theta]/2]];*)

  Graphics[{EdgeForm[Directive[Thick, Black]], RGBColor[0, 0.5, 1], 
    gr}, PlotRange -> (16 {{-1, 1}, {-1, 1}}), ImageSize -> 300]
  ]
Manipulate[MakeScene[\[Beta]], {\[Beta], 0, 1}]

resulting in: enter image description here

I think you can figure out alternate coloring and rotating the entire scene. To change the extent of the squares change the bounds of the Table function.

Probably it can be simplified because I had another geometry. But you can study the mechanism and either adopt mine or adjust your own.

$\endgroup$
  • $\begingroup$ An explanation would be nice, especially how you found the expressions for q and p. $\endgroup$ – C. E. Sep 21 at 11:29
  • $\begingroup$ p and q can be found by some geometry, nothing special actually. They are the center-to-center 'unit vectors' of the squares in both directions. $\endgroup$ – SHuisman Sep 21 at 13:24
11
$\begingroup$

This almost, but not quite, matches the requested figure.

square = {{0, 0}, {1, 0}, {1, 1}, {0, 1}};
n = 5;
redlattice = Flatten[Table[{x, y}, {y, -n + 1, n}, {x, -n + 1, n}], 1];
greenlattice = Flatten[Table[{x, y}, {y, -n + 1, n - 1}, {x, -n + 1, n - 1}], 1];

Manipulate[
 redsquares = RotationTransform[θ + π/2, #]@square & /@ redlattice;
 temp = RotationTransform[θ + π/2, #]@square & /@ greenlattice;
 greensquares = TranslationTransform[#[[1]] - square[[1]]]@square & /@ temp;
 Graphics[{EdgeForm[Gray], 
   LightRed, Polygon@redsquares,
   LightGreen, Polygon[square], Polygon@greensquares
   }, PlotRange -> {{-2 n - 1, 2 n + 2}, {-2 n - 1, 2 n + 2}}], {θ, 0, π}]

enter image description here

$\endgroup$
10
$\begingroup$

Extending @ MelaGo answer...in spirit of OP...but needs improvement:

square = {{0, 0}, {1, 0}, {1, 1}, {0, 1}};
f[j_, k_] := Table[{u, k}, {u, -j, j}];
top[n_] := Join @@ (f @@@ Table[{n - j, j}, {j, 0, n}]);
bot[n_] := Join @@ (f @@@ Table[{n - j, -j}, {j, 1, n}]);
full[n_] := Join[top[n], bot[n]];

funr[p_] := RegionCentroid[Polygon[RotationTransform[Pi/2, p]@square]]
fung[p_] := 
 RegionCentroid[
  Polygon[TranslationTransform[(RotationTransform[Pi/2, p]@
        square)[[1]]]@square]]
lattr[n_] := Select[full[n], funr[#][[1]] != -n - 1/2 &]
lattg[n_] := Select[full[n], fung[#][[1]] != n + 1/2 &]
vis[a_, n_] := Module[{red = lattr[n], green = lattg[n], rs, tmp, gs},
  rs = RotationTransform[a + \[Pi]/2, #]@square & /@ red;
  tmp = RotationTransform[a + \[Pi]/2, #]@square & /@ green;
  gs = TranslationTransform[#[[1]]]@square & /@ tmp;
  Graphics[{EdgeForm[Gray], LightRed, Polygon@rs, LightGreen, 
    Polygon@gs}, PlotRange -> {{-2 n, 2 n}, {-2 n, 2 n}}]]
Manipulate[vis[a, n], {a, 0, \[Pi]}, {n, Range[2, 7]}]

enter image description here

Some exported gifs: enter image description here

enter image description here

$\endgroup$
9
$\begingroup$

I modified the SHuisman's code a bit. It turned out to be almost a complete match with the required animation.

\[CurlyPhi] = Tan[1/3.];
Clear[DrawPlus, MakeScene]
DrawPlus[p : {x_, y_}, \[Theta]_] := 
 Module[{line}, line = Polygon[{{3, 1}, {1, -3}, {-3, -1}, {-1, 3}}];
  line = GeometricTransformation[line, RotationMatrix[\[Theta]]];
  GeometricTransformation[line, TranslationTransform[p]]]
MakeScene[\[Alpha]_] := 
 Module[{p, q, \[Theta] = \[Pi] \[Alpha], gr}, 
  p = {1., -3.} + 
    Sqrt[10] {Cos[\[Theta] - \[CurlyPhi]], -Sin[\[Theta] - \
\[CurlyPhi]]};
  q = {3., 1.} + 
    Sqrt[10] {Sin[\[Theta] - \[CurlyPhi]], 
      Cos[\[Theta] - \[CurlyPhi]]};
  gr = Flatten[
    Table[{If[OddQ[i + j], LightRed, LightGreen], 
      DrawPlus[i p + j q, If[EvenQ[i + j], 0, -\[Theta]]]}, {i, -3, 
      3}, {j, -3, 3}], 1];
  Graphics[{{EdgeForm[Directive[Thick, Blue, Opacity[.5]]], 
     Rotate[gr, Pi/7]}, {Red, PointSize[.01], 
     Point[{{0, 0}, {2, 2}}]}}, PlotRange -> (30 {{-1, 1}, {-1, 1}}), 
   ImageSize -> 500]]
lst = Table[MakeScene[\[Beta]], {\[Beta], 0, 1, .02}];
ListAnimate[lst]

Figure 1

$\endgroup$
8
$\begingroup$

enter image description here

pts = {{0, 0}, {1, 0}, {1, 1}, {0, 1}};

ClearAll[p, nextpt, redsquares, greensquares]

nextpt = AssociationThread[pts, RotateRight[pts]];

p[m_] := Tuples[{SparseArray[DiamondMatrix[m - 1]]["NonzeroPositions"] - m, pts}]

redsquares[t_, m_] := Rotate[Rectangle[], t + Pi/2, #] & /@ DeleteDuplicates[Total /@ p[m]]

greensquares[t_, m_] := Translate[Rectangle[], 
  DeleteDuplicates[RotationTransform[t + Pi/2, nextpt[#2] + #]@#2 - #2 & @@@ p[m]]]

Show one or more groups of rotating rectangles:

n = 10;
Manipulate[Row[Table[Graphics[{EdgeForm[Gray], 
  LightRed, redsquares[θ, m], LightGreen, Rectangle[], greensquares[θ, m]}, 
    PlotRange -> {{-2 m, 2 m + 1}, {-2 m, 2 m + 1}}, 
    ImageSize -> 200 m/2], {m, Sort @ ml}], Spacer[5]], 
 {{ml, {1}}, Range[n], TogglerBar}, {θ, 0, Pi}]

enter image description here

The animation above produced using

ml = {1, 2, 4}; 
frames = Table[Row[Table[Graphics[{EdgeForm[Gray], 
    LightRed, redsquares[θ, m], LightGreen, Rectangle[], greensquares[θ, m]}, 
   PlotRange -> {{-2 m, 2 m + 1}, {-2 m, 2 m + 1}}, ImageSize -> 200 m/2], 
 {m, ml}], Spacer[5]], {θ, 0, Pi, Pi/64}];

Export["rotatingrectangles.gif", frames]
$\endgroup$
  • $\begingroup$ I really like your answer. $\endgroup$ – ubpdqn Sep 26 at 7:44
  • $\begingroup$ Thank you @ubpdqn. $\endgroup$ – kglr Sep 26 at 13:50

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.