9
$\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$
13
+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.

| improve this answer | |
$\endgroup$
  • $\begingroup$ An explanation would be nice, especially how you found the expressions for q and p. $\endgroup$ – C. E. Sep 21 '19 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 '19 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

| improve this answer | |
$\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

| improve this answer | |
$\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

| improve this answer | |
$\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]
| improve this answer | |
$\endgroup$
  • $\begingroup$ I really like your answer. $\endgroup$ – ubpdqn Sep 26 '19 at 7:44
  • $\begingroup$ Thank you @ubpdqn. $\endgroup$ – kglr Sep 26 '19 at 13:50
2
$\begingroup$

Inspired by SHuisman, using complex number

Manipulate[
 Graphics[{
   Table[With[{k = Mod[i + j, 2]}, {EdgeForm[Gray], RGBColor[k, 1 - k, 0, .2],
      Polygon@ReIm[(1 + I) (E^(I θ) + I) (i + I j) +  E^(I k θ) {-1-I, I-1, 1+I, 1-I}]}],
    {i, -n, n}, {j, -n, n}]
   }, PlotRange -> 4 n + 2
  ], {{n, 3}, 1, 9, 1}, {θ, 0., Pi}]

enter image description here

| improve this answer | |
$\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.