# The correct way to draw this fractal

As shown in the picture, I want to draw such a fractal

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


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

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

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


• How about replace[square[{p1_, p2_, p3_, p4_}, i_]] :=Delete[squares ..., Switch[i, 0, {}, 1, 3, 2, 4, 3, 1, 4, 2]]? Commented Apr 2, 2021 at 17:57

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}, _}]@

step = ReplaceAll[{c : Red | Green | Blue | Orange | Black, p_Polygon} :>


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


Iterate step 6 steps and re-color the leaves:

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


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


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", Join[frames, Reverse @ frames],
"AnimationRepetitions" -> Infinity, "DisplayDurations" -> 1/4]


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]


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


Click on this image to see a higher resolution image.

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


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


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


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


Clear["*"];
f[{p_, i_}] := Delete[Table[{p[[x]] + (p[[x]] - #)/2 & /@ p, x}, {x, 4}], i];
list = NestList[Join @@ f /@ # &, {{N@{{0, 0}, {1, 0}, {1, 1}, {0, 1}}, {}}}, 5];
Graphics[{EdgeForm[Blue], LightBlue, Polygon /@ list[[;; , ;; , 1]]}]
`

• This seems to be the shortest code so far.
– miss
Commented Oct 18, 2023 at 4:25