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.

$\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$ Jan 19, 2021 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$ Jan 19, 2021 at 12:50

5 Answers 5

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}}]]
$\endgroup$
3
  • 1
    $\begingroup$ +1 Replace With by Manipulate, e.g., Manipulate[Graphics[ ... ], {{n, 4}, Range[7], ControlType -> SetterBar}] $\endgroup$
    – Bob Hanlon
    Jan 19, 2021 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$ Jan 20, 2021 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$ Jan 20, 2021 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

$\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

$\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$ Jan 21, 2021 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, 2021 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

$\endgroup$
2
$\begingroup$
With[{n=4},
 Graphics[MapIndexed[{ColorData["Rainbow",(Tr@#2-1)/2/n],Rectangle@@#, 
  Text[Style[2^-Tr@#2,White,12],Mean@#]}&,
   Join@@ReIm@NestList[(#+1)/2&,{{I,2+2I},{0,1+I}}/2,n-1]]]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.