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$
    – Adam
    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$
    – miss
    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$
    – heropup
    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$
    – Adam
    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$
    – Sidharth Ghoshal
    Commented Oct 20, 2023 at 4:12

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.