12
$\begingroup$

enter image description here

For the first square, I tried

Graphics[{Green, Rectangle[{0, 0}, {3, 3}]}]
Improve this question
$\endgroup$

9 Answers 9

Reset to default
25
$\begingroup$

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

enter image description here

Improve this answer
$\endgroup$
13
$\begingroup$ 
ArrayMesh/@SubstitutionSystem[{1->{{1,0,1},{0,1,0},{1,0,1}},0->Table[0,3,3]},{{1}},5]

enter image description here

enter image description here

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ beautiful answer, SubstitutionSystem is such an overlooked function $\endgroup$ Commented Oct 15, 2023 at 3:10
12
$\begingroup$ 
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]]

enter image description here

Improve this answer
$\endgroup$
11
$\begingroup$ 
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]]

enter image description here

Improve this answer
$\endgroup$
11
$\begingroup$ 
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}] &]]

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

pic2

Improve this answer
$\endgroup$
10
$\begingroup$ 
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}]

enter image description here

Improve this answer
$\endgroup$
10
$\begingroup$

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

FractalStep =
  Thread[
    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]]
Improve this answer
$\endgroup$
1
  • $\begingroup$ 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 . $\endgroup$ Commented Oct 15, 2023 at 3:52
10
$\begingroup$ 
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]]

enter image description here

Or

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

enter image description here

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

enter image description here

Improve this answer
$\endgroup$
10
$\begingroup$

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]}},
  With[{frac=MapThread[Rectangle,{#2-1/2,#2+1/2}]&@@Nest[#/.rule&,{1,{{0,0}}},#]&},
    Table[
      Framed@Graphics[frac@Floor@i,PlotRange->(3^(i-1)/2{{-1,1},{-1,1}})]
    ,{i,1,5,.1}]
  ]],i];
ListAnimate@frames

in and out

And the forever version, not perfect

looping

Improve this answer
$\endgroup$
3
  • $\begingroup$ 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? $\endgroup$ Commented Oct 16, 2023 at 1:24
  • $\begingroup$ I'm flabbergasted when i pause a frame and see straight lines, the illusion feels so real! $\endgroup$ Commented Oct 16, 2023 at 3:53
  • $\begingroup$ Staring at that for a while (and watching the squares zoom down) and then scrolling down to this text does something very weird for me (feels like a very mild visual distortion). As such when staring I don’t seem to notice the curve sides effect you all are perceiving. $\endgroup$ Commented Oct 20, 2023 at 4:12

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.