8
$\begingroup$

I am teaching the idea of infinite geometric series to high school students, looking for hints to create the diagram below using Mathematica. (I don't need the labels). I can do it manually, but hoping for a "manipulate" kind of solution to illustrate the process. divided square

Any help is appreciated.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ 1/32 and 1/128 being at the "bottom" of the larger rectangles enclosing them instead of at the "top" complicates things. Is this necessary? $\endgroup$ – J. M.'s ennui♦ Jan 19 at 12:41
  • $\begingroup$ No, the actual layout doesn't really matter, as long as it is visibly being divided up 1/2, 1/2 of the half, etc. $\endgroup$ – Tom De Vries Jan 19 at 12:50
10
$\begingroup$

A starting point:

With[{n = 4}, 
     Graphics[MapIndexed[{ColorData[97] @@ #2, #1} &, 
                         Append[Riffle[
                         Table[Rectangle[{1 - 2^(1 - k), 0}, {1 - 2^-k, 2^-k}], {k, n}], 
                         Table[Rectangle[{1 - 2^(1 - k), 2^-k}, {1, 2^(1 - k)}], {k, n}]],
                         Rectangle[{1 - 2^-n, 0}, {1, 2^-n}]]], 
              PlotRange -> {{0, 1}, {0, 1}}]]

halved rectangles

Here's something with labels. I'll let someone else work out how to properly size the text:

With[{n = 4}, 
     Graphics[MapIndexed[{{ColorData[97] @@ #2, #1},
                          {White, Text[Style[ToString[1/2^First[#2], InputForm], Tiny], 
                                       Mean[List @@ #1]]}} &, 
                         Append[Riffle[
                         Table[Rectangle[{1 - 2^(1 - k), 2^-k}, {1, 2^(1 - k)}], {k, n}], 
                         Table[Rectangle[{1 - 2^(1 - k), 0}, {1 - 2^-k, 2^-k}], {k, n}]], 
                         Rectangle[{1 - 2^-n, 0}, {1, 2^-n}]]], 
              PlotRange -> {{0, 1}, {0, 1}}]]
Improve this answer
$\endgroup$
3
  • 1
    $\begingroup$ +1 Replace With by Manipulate, e.g., Manipulate[Graphics[ ... ], {{n, 4}, Range[7], ControlType -> SetterBar}] $\endgroup$ – Bob Hanlon Jan 19 at 16:08
  • $\begingroup$ @Tom, since you're discussing geometric series with kids, an interesting exercise is how I derived the coordinate expressions within the Rectangle[] objects. $\endgroup$ – J. M.'s ennui♦ Jan 20 at 5:39
  • $\begingroup$ I'm working online, so sadly, little discussion! This is mostly to help illustrate the ideas, and your answer really helped with that! $\endgroup$ – Tom De Vries Jan 20 at 13:08
6
$\begingroup$

Using ArrayPad + Fold + Nest + MatrixPlot

ClearAll[padMat]
padMat = Fold[ArrayPad[#, RotateLeft[{{0}, {Length @ #, 0}}, #2 - 1], 1 + Max @ #] &, 
  #, {1, 2}] &;

Examples:

With[{n = 6}, MatrixPlot[Nest[padMat, {{1}}, n] /. x_Integer :> ColorData[97][x], 
 ImageSize -> 600, Frame -> False, Mesh -> All]]

enter image description here

Grid @ Partition[#, 3] & @ Table[
 MatrixPlot[Nest[padMat, {{1}}, n] /. x_Integer :> ColorData[97][x], 
   ImageSize -> 300, Frame -> False, Mesh -> All], {n, 0, 5}]

enter image description here

Using Fold + ArrayPad only:

ClearAll[paddedMat]
paddedMat[n_] := Fold[
  ArrayPad[#, RotateLeft[{{0}, {Length @ #, 0}}, #2 - 1], 1 + Max @ #] &, 
  {{1}}, Mod[Range[n], 2, 1]];

Example:

With[{n = 10}, MatrixPlot[paddedMat[n] /. x_Integer :> ColorData[97][x], 
  ImageSize -> 700, Frame -> False, Mesh -> All]]

enter image description here

We can add labels using Epilog:

With[{n = 8}, 
 MatrixPlot[paddedMat[n] /. x_Integer :> ColorData[97][x], 
  Mesh -> All, ImageSize -> 700, Frame -> False, 
  Epilog -> MapIndexed[Text[Style[2^-Min[#2[[1]], n], 
       Max[8, 72/Min[#2[[1]], n - 1]]], #] &, 
    Reverse[{# - 1, 2^(Floor[n/2]) - #2} + 1/2 & @@@ 
     (Reverse @ Mean[Position[paddedMat[n], #]] & /@ Range[1 + n])]]]]

enter image description here

Improve this answer
$\endgroup$
4
$\begingroup$

We can also use affine transformations of the unit rectangle to get the desired picture:

ClearAll[rectangleCoords]
rectangleCoords[n_] :=  Module[{mod = Mod[Range[0, n - 2], 2], 
   sy = 2^Floor[Range[0, n - 2]/2], rcoords = {{0, 0}, {1, 1}}}, 
  Through[(Reverse @ Prepend[Identity][AffineTransform[{{{#, 0}, {0, #2}}, {##3}}] & @@@
    (Transpose[{(1 + mod) #, #, (1 - mod) #, mod #}] & @ sy)])@ rcoords]]

Examples:

With[{n = 9}, 
 Graphics[MapIndexed[{ColorData[97]@#2[[1]], Rectangle @@ #, Black, 
     Text[Style[2^-Min[#2[[1]], n - 1], Max[8, 72/Min[#2[[1]], n - 1]]], Mean@#]} &, 
   rectangleCoords[n]], ImageSize -> 1 -> 40]]

enter image description here

Manipulate[Graphics[MapIndexed[{ColorData[97]@#2[[1]], Rectangle @@ #, Black, 
  Text[Style[2^-Min[#2[[1]], n - 1], 
       Max[8, 72/Max[1, Min[#2[[1]], n - 1]]]], Mean @ #]} &, rectangleCoords[n]], 
  ImageSize -> 800], 
 {{n, 7}, Range[11], SetterBar}]

enter image description here

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ This is a great answer, but I don't understand why sometimes, as seen in the last screen shot, you get a "rectangle" instead of the square. Otherwise, the "perfect" answer! Seems to have an error for "even" values of n...? $\endgroup$ – Tom De Vries Jan 21 at 12:03
  • $\begingroup$ @TomDeVries, in this implementation, the parameter n represents the number of rectangles. For odd n we get a square; for even n we get a rectangle instead of a square. $\endgroup$ – kglr Jan 21 at 12:09
2
$\begingroup$

We can also recursively divide the bottom-right rectangle into three rectangles as follows:

ClearAll[threerects, step, rectlist]
threerects = # /. Rectangle[{a_, b_}, {c_, d_}] :> 
     {Rectangle[{a, (b + d)/2}, {c, d}], 
      Rectangle[{a, b}, {a + c, b + d}/2], 
      Rectangle[{(a + c)/2, b}, {c, (b + d)/2}]} &;

Graphics[MapIndexed[{{Red, Green, Blue}[[#2[[1]]]], #} &, 
  threerects[Rectangle[{0, 0}, {1, 1}]]]]

enter image description here

We use threerects recursively to replace the last rectangle in a list of rectangles starting with a list containing only the unit rectangle:

ClearAll[step, rectlist]

step = # /. {a___Rectangle, b_Rectangle} :> Flatten[{a, threerects @ b}] &;

rectlist[n_] := Nest[step, {Rectangle[{0, 0}, {1, 1}]}, n]

Examples:

frames = Table[Graphics[MapIndexed[{ColorData[97]@#2[[1]], #} &, rectlist @ n], 
    ImageSize -> 360], {n, 0, 7}];

Export["rectangles.gif", frames, 
 AnimationRepetitions -> Infinity, 
 DisplayAllSteps -> True, 
 "DisplayDurations" -> Table[1., Length[frames]]]

enter image description here

With[{n = 4}, Graphics[MapIndexed[{ColorData[97] @ #2[[1]], #, Black, 
     Text[Style[2^(-Min[#2[[1]], 2 n]), Max[8, 72/Max[1, Min[#2[[1]], 2 n]]]], 
        RegionCentroid @ #]} &, rectlist @ n],
   ImageSize -> 600]]

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.