# How to partition a square into successive halves

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.

Any help is appreciated.

• 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? Jan 19, 2021 at 12:41
• 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. Jan 19, 2021 at 12:50

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}}]]


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}}]]

• +1 Replace With by Manipulate, e.g., Manipulate[Graphics[ ... ], {{n, 4}, Range[7], ControlType -> SetterBar}] Jan 19, 2021 at 16:08
• @Tom, since you're discussing geometric series with kids, an interesting exercise is how I derived the coordinate expressions within the Rectangle[] objects. Jan 20, 2021 at 5:39
• I'm working online, so sadly, little discussion! This is mostly to help illustrate the ideas, and your answer really helped with that! Jan 20, 2021 at 13:08

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]]


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


Using Fold + ArrayPad only:

ClearAll[paddedMat]
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]]


We can add labels using Epilog:

With[{n = 8},
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])]]]]


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]]


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}]


• 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...? Jan 21, 2021 at 12:03
• @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.
– kglr
Jan 21, 2021 at 12:09

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}]]]]


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]]]


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]]


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]]]]