# How can I draw sequence of these fractal squares?

For the first square, I tried

Graphics[{Green, Rectangle[{0, 0}, {3, 3}]}]


How about using ArrayMesh and KroneckerProduct:

shape = {{1,0,1},{0,1,0},{1,0,1}};
mesh[0] = ArrayMesh[{{1}}];
mesh[1] = ArrayMesh[shape];
mesh[n_] := ArrayMesh[KroneckerProduct@@ConstantArray[shape, n]]


Then:

Row[mesh/@Range[0,3],Spacer[4]]


ArrayMesh/@SubstitutionSystem[{1->{{1,0,1},{0,1,0},{1,0,1}},0->Table[0,3,3]},{{1}},5]


• beautiful answer, SubstitutionSystem is such an overlooked function
Commented Oct 15, 2023 at 3:10
ClearAll[amesh]

amesh[n_, options : OptionsPattern[]] :=
Map[ArrayMesh[#, options, ImageSize -> 150] &]@
SubstitutionSystem[
{1 -> {{1, 0, 1}, {0, 1, 0}, {1, 0, 1}},
0 -> ConstantArray[0, {3, 3}]},
{{1}}, n - 1]

Row[amesh[4, BaseStyle -> RGBColor[1/2, 3/4, 1/2, 3/4]], Spacer[10]]


subdivideRectangle = ReplaceAll[r_Rectangle :>
(Scale[r, 1/3 , #] & /@ {{1/2, 1/2}, {0, 1}, {0, 0}, {1, 0}, {1, 1}})];

fractalSquares[n_, color_ : Automatic , options : OptionsPattern[]] :=
NestList[
subdivideRectangle,
Graphics[{color /. Automatic -> RGBColor[.5, .75, .5], Rectangle[]},
options, ImageSize -> 200],
n - 1]

Row[fractalSquares[4], Spacer[10]]


p1 = NestList[
ArrayFlatten[# /. 1 -> {{1, 0, 1}, {0, 1, 0}, {1, 0, 1}}] &, {{1}},
4]; GraphicsRow[
p1 // Map[
ArrayPlot[#,
ColorRules -> {1 -> Blend[{Darker@Green, White}], 0 -> None}] &]]


Thanks to @flc. Related Post.

## 3d version:

p1 = NestList[
ArrayFlatten[# /.
1 -> {{{1, 0, 1}, {0, 0, 0}, {1, 0, 1}}, {{0, 0, 0}, {0, 1,
0}, {0, 0, 0}}, {{1, 0, 1}, {0, 0, 0}, {1, 0, 1}}},
3] &, {{{1}}}, 4];
p1 // Map[
ArrayPlot3D[#, ColorRules -> {1 -> Blend[{Darker@Green, White}]}] &]


Clear["Global*"]
rule = Rectangle[{a_, b_}, {c_,
d_}] :> {Rectangle[{a, b}, {(2 a)/3 + c/3, (2 b)/3 + d/3}],
Rectangle[{(2 a)/3 + c/3, (2 b)/3 + d/3}, {a/3 + (2 c)/3,
b/3 + (2 d)/3}],
Rectangle[{a/3 + (2 c)/3, b/3 + (2 d)/3}, {c, d}],
Rectangle[{a, b/3 + (2 d)/3}, {(2 a)/3 + c/3, d}],
Rectangle[{a/3 + (2 c)/3, b}, {c, (2 b)/3 + d/3}]};

GraphicsGrid[{NestList[# /. rule &, Rectangle[{0, 0}, {1, 1}], 4] //
Map[Graphics[{Blend[{Darker@Green, White}], #}] &]},
ImageSize -> {5*160, 160}]


Riffing on Syed's solution with some point-free flair (add styles to suit):

FractalStep =
Composition[
{TranslationTransform[{0, 0}],
TranslationTransform[{2/3, 0}],
TranslationTransform[{0, 2/3}],
TranslationTransform[{2/3, 2/3}],
TranslationTransform[{1/3, 1/3}]},
ScalingTransform[{1/3, 1/3}]]];
InitialPoints = {{{0, 0}, {1, 0}, {1, 1}, {0, 1}}};
GraphicsRow[Graphics@*Polygon /@ NestList[Catenate@*Through@*FractalStep, InitialPoints, 3]]

• p1 = Polygon /@ NestList[Catenate@*Through@*FractalStep, InitialPoints, 3]; GraphicsRow[p1 // Map[Graphics[{Blend[{Darker@Green, White}], #}] &]], Anyone can try replacing the code after InitialPoints to modify the color .
– miss
Commented Oct 15, 2023 at 3:52
shape = {{1, 0, 1}, {0, 1, 0}, {1, 0, 1}};
newshape[oldshape_] :=
Flatten[Table[
Table[p shape, {p, row}], {row, oldshape}], {{1, 3}, {2, 4}}]

fr = NestList[newshape, shape, 3];

Row[ArrayPlot[#, Frame -> None, ImageSize -> 200] & /@ fr, Spacer[5]]


Or

Row[ColorNegate@Image[#, ImageSize -> 200] & /@ fr, Spacer[5]]


Updated with alternative:

newshape2[oldshape_] :=
ArrayFlatten[Table[Table[p shape, {p, row}], {row, oldshape}]]

fr2 = NestList[newshape2, shape, 3];
Row[ArrayPlot[#, Frame -> None, ImageSize -> 200] & /@ fr2, Spacer[5]]


An animated version for fun

frames=Monitor[
With[{rule={i_,p_}:>{3i,Join@@Outer[Plus,p,CirclePoints[Sqrt[2]i,4]~Join~{{0,0}},1]}},
Table[
Framed@Graphics[frac@Floor@i,PlotRange->(3^(i-1)/2{{-1,1},{-1,1}})]
,{i,1,5,.1}]
]],i];
ListAnimate@frames
`

And the forever version, not perfect

• That's wild! Is it just me, or is there an optical illusion where the squares near the center start to look like their sides curve slightly outward? Commented Oct 16, 2023 at 1:24
• I'm flabbergasted when i pause a frame and see straight lines, the illusion feels so real!