11
$\begingroup$

As shown in the picture, I want to draw such a fractal
enter image description here
When the number of iterations is greater than 2, my code can't get the expected result

Clear[f, points];
f[{a_, b_, c_, d_}] := {
   {a/2 + {-1.5, -1.5}, b/2 + {-1.5, -1.5}, c/2 + {-1.5, -1.5}, d/2 + {-1.5, -1.5}},
   
   {a/2 + {1.5, -1.5}, b/2 + {1.5, -1.5}, c/2 + {1.5, -1.5}, d/2 + {1.5, -1.5}},
   
   {a/2 + {1.5, 1.5}, b/2 + {1.5, 1.5}, c/2 + {1.5, 1.5}, d/2 + {1.5, 1.5}},
   
   {a/2 + {-1.5, 1.5}, b/2 + {-1.5, 1.5}, c/2 + {-1.5, 1.5}, d/2 + {-1.5, 1.5}}
   };

points = NestList[Join @@ f /@ # &, N@{{{-1, -1}, {1, -1}, {1, 1}, {-1, 1}}}, 3];
Graphics[{Lighter@Blue, Polygon /@ points}]

enter image description here
I don't know how to delete the extra squares, or there is a better way to construct.

$\endgroup$
16
$\begingroup$

I see five types of squares that all move to the next step differently:

enter image description here

We start with 1 square of type 0 that produces four squares at level 1. Each of those produces three squares at level 2, none of which overlaps with the square at level 0. We can code this in terms of a square[pts_,type_] symbol explicitly as follows:

replace[square[{p1_, p2_, p3_, p4_}, 0]] := 
  {square[{p1 + (p1 - p3)/2, p1 + (p1 - p4)/2, p1, p1 + (p1 - p2)/2}, 
    1],
   square[{p2 + (p2 - p3)/2, p2 + (p2 - p4)/2, p2 + (p2 - p1)/2, p2}, 
    2],
   square[{p3, p3 + (p3 - p4)/2, p3 + (p3 - p1)/2, p3 + (p3 - p2)/2}, 
    3],
   square[{p4 + (p4 - p3)/2, p4, p4 + (p4 - p1)/2, p4 + (p4 - p2)/2}, 
    4]};
replace[square[{p1_, p2_, p3_, p4_}, 1]] := 
  {square[{p1 + (p1 - p3)/2, p1 + (p1 - p4)/2, p1, p1 + (p1 - p2)/2}, 
    1],
   square[{p2 + (p2 - p3)/2, p2 + (p2 - p4)/2, p2 + (p2 - p1)/2, p2}, 
    2],
   square[{p4 + (p4 - p3)/2, p4, p4 + (p4 - p1)/2, p4 + (p4 - p2)/2}, 
    4]};
replace[square[{p1_, p2_, p3_, p4_}, 2]] := 
  {square[{p1 + (p1 - p3)/2, p1 + (p1 - p4)/2, p1, p1 + (p1 - p2)/2}, 
    1],
   square[{p2 + (p2 - p3)/2, p2 + (p2 - p4)/2, p2 + (p2 - p1)/2, p2}, 
    2],
   square[{p3, p3 + (p3 - p4)/2, p3 + (p3 - p1)/2, p3 + (p3 - p2)/2}, 
    3]};
replace[square[{p1_, p2_, p3_, p4_}, 3]] := 
  {square[{p2 + (p2 - p3)/2, p2 + (p2 - p4)/2, p2 + (p2 - p1)/2, p2}, 
    2],
   square[{p3, p3 + (p3 - p4)/2, p3 + (p3 - p1)/2, p3 + (p3 - p2)/2}, 
    3],
   square[{p4 + (p4 - p3)/2, p4, p4 + (p4 - p1)/2, p4 + (p4 - p2)/2}, 
    4]};
replace[square[{p1_, p2_, p3_, p4_}, 4]] := 
  {square[{p1 + (p1 - p3)/2, p1 + (p1 - p4)/2, p1, p1 + (p1 - p2)/2}, 
    1],
   square[{p3, p3 + (p3 - p4)/2, p3 + (p3 - p1)/2, p3 + (p3 - p2)/2}, 
    3],
   square[{p4 + (p4 - p3)/2, p4, p4 + (p4 - p1)/2, p4 + (p4 - p2)/2}, 
    4]};
replace[squares_List] := replace /@ squares;

We can then simply use a NestList command to produce your image:

Graphics[{GrayLevel[0.7], EdgeForm[{Thickness[0.001], Black}],
  NestList[replace, square[{{0, 0}, {1, 0}, {1, 1}, {0, 1}}, 0], 6] /. 
  square[pts_, _] -> Polygon[pts]
 }]

enter image description here

$\endgroup$
1
  • $\begingroup$ How about replace[square[{p1_, p2_, p3_, p4_}, i_]] :=Delete[squares ..., Switch[i, 0, {}, 1, 3, 2, 4, 3, 1, 4, 2]]? $\endgroup$
    – chyanog
    Apr 2 at 17:57
9
$\begingroup$

enter image description here

Starting with the unit rectangle centered at origin, add 4 scaled squares at each color-coded corner. At each step, we attach to each colored square three squares at three corners based on the color of the square. Once a square is processed, we change its color so that it is not touched in later steps.

ClearAll[addSquares, step]

atlist = AffineTransform[{{{1/2, 0}, {0, 1/2}}, #}] & /@ Tuples[{-1, 1} 3/4, 2];

addSquares[c_, Polygon[x_]] := {#, Polygon[#2 @ x]} & @@@ 
  DeleteCases[{c /. {Red -> Orange, Orange -> Red, Green -> Blue, Blue -> Green}, _}]@
    Thread[{{Red, Green, Blue, Orange}, atlist}];


step = ReplaceAll[{c : Red | Green | Blue | Orange | Black, p_Polygon} :> 
   {LightBlue, p, addSquares[c, p]}];

Start with a polygon centered at {0, 0}:

square = Polygon[{{-1, -1}, {1, -1}, {1, 1}, {-1, 1}}/2];


Row[Graphics[{EdgeForm[{Thin, Gray}], #}, ImageSize -> 200] & /@ 
    NestList[step, {Black, square}, 3], Spacer[10]]

enter image description here

Iterate step 6 steps and re-color the leaves:

Graphics[{EdgeForm[{Thin, Gray}], 
  Nest[step, {Black, square}, 6] /. _?ColorQ -> LightBlue}]

enter image description here

Graphics[{EdgeForm[{Thin, Gray}], 
  Nest[step, {Black, square}, 6] /. _?ColorQ :> RandomColor[]}]

enter image description here

Animation above produced with:

frames = Graphics[{EdgeForm[{Thin, Gray}], # /. _?ColorQ -> LightBlue}, 
       ImageSize -> Large, PlotRange -> {{-3/2, 3/2}, {-3/2, 3/2}}] & /@ 
  NestList[step, {Black, square}, 7];

Export["fractalsquares.gif", frames, 
 "AnimationRepetitions" -> Infinity, "DisplayDurations" -> 1]
$\endgroup$
6
$\begingroup$

I don't know if there is a "right" way, but here is how I did this:

(* next converts an index (which is a list steps taken from {1,2,3,4}
   and indirected through verts.dirs) to one of the next three leaves
   (dir is in {-1,0,1}) *)

next[dir_, index_] := Append[index, Mod[Last[index] + dir - 1, 4] + 1]

(* spawn adds the set of indices for the next level of the tree *)

spawn[indices_] := 
 Module[{last = Last[indices], i, n, lst, nxt = {}}, n = Length[last];
   For[i = 1, i <= n, ++i, lst = last[[i]]; 
   nxt = Append[Append[Append[nxt, next[-1, lst]], next[0, lst]], 
     next[1, lst]]]; Append[indices, nxt]]

(* verts takes an index to a leaf and converts it to the vertices of
   a square for that leaf *)

verts[index_] := 
 Module[{dirs = {{1, 1}, {-1, 1}, {-1, -1}, {1, -1}}, 
   n = Length[index], pos}, 
  pos = {0, 0} + 
    3 Sum[dirs[[index[[k]]]]/2^k, {k, 1, n}]; (pos + #) & /@ (dirs/
     2^n)]

(* polys takes a depth and computes a list of polygons (squares)
   to be rendered *)

polys[depth_] := 
 Module[{indices = {{{}}, {{1}, {2}, {3}, {4}}}}, 
  MapAt[Polygon[verts[#]] &, Nest[spawn, indices, depth], {All, All}]]

(* render the fractal *)

Graphics[{{Yellow, Polygon[3 {{1, 1}, {-1, 1}, {-1, -1}, {1, -1}}]}, 
  EdgeForm[None], FaceForm[Blue], polys[7]}, ImageSize -> 512]

fractal image

To see more information about the levels, I have added color:

Module[{fractal = polys[7], 
  spectrum = {Red, Orange, Yellow, Green, Blue, 
    Blend[{Blue, Purple}, 2/3], Purple, Red, Blue}, k}, 
 For[k = 1, k <= 9, ++k, 
  fractal = Insert[fractal, spectrum[[k]], {k, 1}]]; 
 Graphics[{{Lighter[Gray, 4/5], 
    Polygon[3 {{1, 1}, {-1, 1}, {-1, -1}, {1, -1}}]}, EdgeForm[None], 
   fractal}, ImageSize -> 1024]]

spectral fractal

Click on this image to see a higher resolution image.

$\endgroup$
4
$\begingroup$

Scaling and reflecting Rectangle[] iteratively:

ClearAll[iterate, squareSnowflake]

iterate = {#, Scale[Rectangle[], 2^#2, - {1, 1}], 
  GeometricTransformation[#, 
    Table[ReflectionTransform[u, (3 2^(#2 - 1) - 1) {1, 1}], {u, {{0, 1}, {1, 0}}}]]}&;

squareSnowflake = Module[{fl = FoldList[iterate, Rectangle[], Range[#]]}, 
 {fl, 
  GeometricTransformation[Most @ fl, 
    ReflectionTransform[{1, 1}, (3 2^(# - 1) - 1) {1, 1}]]}]&;

Examples:

Using iterate with FoldList generates a picture without the top-tight piece:

Row[Graphics[{EdgeForm[Gray], LightGray, #}, ImageSize -> 200] & /@ 
  FoldList[iterate, Rectangle[], Range[4]], Spacer[10]]

enter image description here

squareSnowflake[n] add the missing piece using a simple reflection of the result from first n-1 steps of FoldList[iterate,...]:

Row[Graphics[{EdgeForm[Gray], LightGray, squareSnowflake @ #}, 
    ImageSize -> 200] & /@ Range[0, 4], Spacer[10]]

enter image description here

Graphics[{EdgeForm[{AbsoluteThickness[1], Lighter @ Gray}], 
   LightGray, squareSnowflake[7]}]

enter image description here

Graphics[{EdgeForm[{AbsoluteThickness[1], Lighter @ Gray}], 
  LightGray, squareSnowflake[7] /. r_Rectangle :> {RandomColor[], r}}]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.