I would like to create a fractal by copying, scaling and rotating the initial element

I want to create a fractal, which looks like this: This is rule 150R, which can be found in NKS, page 439.

However, instead of using a cellular automaton, I want to create this fractal from a single element like this (here the first three steps are shown): Is it possible to do it for 5-10 steps automatically? How can I do that?

It's easier to rotate the element, then it can be displayed like this:

Elm=Graphics[{Rectangle[{1,0},{3,1}],Rectangle[{0,1},{1,3}],Rectangle[{3,1},{4,2}],Rectangle[{1,3},{2,4}],Rectangle[{2.5,2},{3,2.5}],Rectangle[{2,2.5},{2.5,3}]}]; Print[Elm] Then I need to make several scaled down copies, rotate them and place then in the correct positions.

But I don't know how to do that efficiently (I don't know how to do that at all).

Except for rotation, which is simple since there are only 4 directions.

We could do this with rules. It's slightly complicated because it's not a simple recursion. Consider the coloured image in the question. The green element fractals into the three blue elements. And each of the three blue elements into three orange elements. But wait there's more! A couple of orange elements appear on the original green element as well.

Let's start with a description of an element. I am going to use {anchor point, direction 1, direction 2}. I will label them {a, p, q} for brevity. To render an element we can create a rule:

renderRule = {a : {_?AtomQ, _}, p_, q_} :> {
Polygon@{a, a + p - q, a + 2 p, a + p + q},
Polygon@{a + 2 p, a + 2 p + (p - q)/2, a + 3 p, a + 2 p + (p + q)/2},
Polygon@{a + 3 p, a + 3 p + (p - q)/2, a + 4 p, a + 3 p + (p + q)/2},
Polygon@{a + 4 p, a + 4 p + (p - q), a + 6 p, a + 4 p + (p + q)},
Polygon@{a + 6 p - p + q, a + 6 p + 2 q, a + 6 p - 2 p + 4 q, a + 6 p - 3 p + 3 q},
Polygon@{a + p + q, a + 2 q, a + 2 p + 4 q, a + 3 p + 3 q}
};

This takes the description and generates the six polygons.

base = {{0, 0}, {1, 0}, {0, 1}};
Graphics[base /. renderRule] Now we can create the two recursion rules:

r1 = {a : {_?AtomQ, _}, p_, q_} :> {
{a - (p + q)/2, q/2, -p/2},
{a + 6 p + 2 q + (p + q)/2, -q/2, p/2},
{a + 2 p + 4 q - (p - q)/2, p/2, q/2}
};
r2 = {a : {_?AtomQ, _}, p_, q_} :> {
{a + 2 p + q + (p - q)/4, p/4, q/4},
{a + 2 p - q + (p + q)/4, p/4, -q/4}
};

The first takes a description of an element, and creates the three half size ones. The second creates the two quarter size ones.

Graphics[{
Opacity[0.5], EdgeForm[Gray],
Green, base,
Blue, base /. r1,
Orange, base /. r1 /. r1, base /. r2
} /. renderRule] The third level will have:

{base /. r2 /. r1, base /. r1 /. r1 /. r1, base /. r1 /. r2}

So essentially we have all the ways of adding up 1 and 2 to get 3, namely:

{2 + 1, 1 + 1 + 1, 1 + 2}

We can get Mathematica to work this out:

Flatten[Permutations /@ IntegerPartitions[3, All, {1, 2}], 1]

{{2, 1}, {1, 2}, {1, 1, 1}}

With a bit of messing around we can turn this into a function:

level[n_, base_] :=
Fold[ReplaceAll, base, #] & /@ (Flatten[
Permutations /@ IntegerPartitions[n, All, {1, 2}], 1] /. {1 -> r1, 2 -> r2});

And finally:

Graphics[{
Opacity[0.5], EdgeForm[Gray],
Green, base,
Blue, level[1, base],
Orange, level[2, base],
Magenta, level[3, base],
Red, level[4, base]
} /. renderRule, AspectRatio -> Automatic]
• Thank you very much for your answer! This is what I wanted – Yuriy S Sep 29 '16 at 6:22

It looks to me like you're not really generating the rule 150R; you're highlighting the complement. As such, it's not really a self-similar set, just as the complementary intervals of the Cantor set don't form a self-similar set. Nonetheless, it can be generated with a recursive procedure - though, in this case, it's a second order recursion, just as rule 150R is second order.

Let's begin with a base image:

Clear[step];
color = LightPurple;
right1 = {
{{0, 0}, {4, -4}, {6, -2}, {2, 2}},
{{4, -4}, {2, -6}, {4, -8}, {6, -6}},
{{0, -6}, {1, -7}, {2, -6}, {1, -5}}
};
base = Join[right1, Map[#*{-1, 1} &, right1, {2}]];
step = {color, EdgeForm[Black], Polygon[base]};
Graphics[step] As the recursion is second order, we need a second image before we begin the recursion.

color = LightOrange;
mid = Map[2*# - {0, 12} &, base, {2}];
right2 = Translate[Rotate[step, -Pi/2, {0, 0}], {20, -20}];
left2 = Translate[Rotate[step, Pi/2, {0, 0}], {-20, -20}];
step = {
{color, EdgeForm[Black], Polygon[mid]},
{step, right2, left2}
};
Graphics[step] Note that we've taken the original base image, scaled it up by the factor 2, shifted it down and recolored it. We've also added two more copies of step 1 on the side while retaining the original step 1 for a total of 3 copies of step 1. That's almost the general procedure for generating step $n$ from steps $n-1$ and step $n-2$. In general, step $n$ will consist of 1 copy of the original base (with a new color) scaled up by the factor $2^{n-1}$, 3 copies of step $n-1$, and 2 copies of step $n-2$. The overall recipe, expressed recursively, is as follows:

color = LightBlue;
color = LightGreen;
color[n_] := Lighter[ColorData[n - 4], 0.9] /; n > 4;

step[n_] := step[n] = Module[
{mid, left, right, innerTop, innerBot},
mid = Map[2^(n - 1)*# - {0, 6 (2^n - 2)} &, base, {2}];
right = Translate[Rotate[step[n - 1],
-Pi/2, {0, 0}], {4(2^(n+1)-3), -4(2^(n+1)-3)}
];
left = Translate[Rotate[step[n - 1],
Pi/2, {0, 0}], {-4(2^(n+1)-3), -4(2^(n+1)-3)}
];
innerTop = Translate[step[n - 2], {0, -6*2^n}];
innerBot = Translate[Rotate[step[n - 2],
Pi, {0, 0}], {0, -24*(2^(n - 1) - 1)}
];
{{color[n], EdgeForm[Directive[Black, Opacity[0.7]]], Polygon[mid]},
{step[n - 1], right, left, innerTop, innerBot}}];
Grid[Partition[Table[Graphics[step[n], ImageSize -> 300], {n, 3, 6}], 2]] I'm not really sure how the color scheme should go so I just used an Indexed color set. We can generate something like the Cellular Automaton image by setting the polygon colors all to white. That is, set color[n_]=White and rerun with $n=8$ to get: I'm curious how you generated the original CA image for rule 150R. I'm not sure that it can be handled by the built in CellularAutomaton command since it's second order. Here's one approach that generates the image in NKS quite closely:

rule = {{0, 1, 0}, {1, 1, 1}};
T = 10;
rSize = 2^T;
init = {1};
init = Join[Table[0, {rSize}], init, Table[0, {rSize}]];
init = Table[0, {2*rSize + 1}];
init[[rSize + 1]] = 1;
init = {Table[0, 2^(T + 1) + 1], init};
init1 = {0};
init2 = {1};
init = {
Join[Table[0, {rSize}], init1, Table[0, {rSize}]],
Join[Table[0, {rSize}], init2, Table[0, {rSize}]]
};
step[{list2_, list1_}] := {list1, Mod[
rule[[1, 1]]*RotateLeft[list2] + rule[[1, 2]]*list2 +
rule[[1, 3]]*RotateRight[list2] +
rule[[2, 1]]*RotateLeft[list1] + rule[[2, 2]]*list1 +
rule[[2, 3]]*RotateRight[list1],2]};
evo = Last /@ NestList[step, init, rSize];
ArrayPlot[evo] The obvious difference is that this image is triangular, growing the way we expect a CA to grow.

• Mark, thank you for the asnwer. I generated the CA in Mathemtica without using any built-in procedures, as for the triangular shape, I've just cut the corners off by hand so it would resemble what I wanted to build with blocks – Yuriy S Sep 29 '16 at 6:21