12
$\begingroup$

enter image description here

For the first square, I tried

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

9 Answers 9

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

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

$\endgroup$
1
  • 1
    $\begingroup$ beautiful answer, SubstitutionSystem is such an overlooked function $\endgroup$
    – Adam
    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

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

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

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

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

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

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