15
$\begingroup$

I want to create a fractal, which looks like this:

enter image description here

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):

enter image description here

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]

enter image description here

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.

$\endgroup$
15
$\begingroup$

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]

1

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]

2

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]

3

$\endgroup$
  • $\begingroup$ Thank you very much for your answer! This is what I wanted $\endgroup$ – Yuriy S Sep 29 '16 at 6:22
11
$\begingroup$

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[1] = 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[1] = {color[1], EdgeForm[Black], Polygon[base]};
Graphics[step[1]]

enter image description here

As the recursion is second order, we need a second image before we begin the recursion.

color[2] = LightOrange;
mid = Map[2*# - {0, 12} &, base, {2}];
right2 = Translate[Rotate[step[1], -Pi/2, {0, 0}], {20, -20}];
left2 = Translate[Rotate[step[1], Pi/2, {0, 0}], {-20, -20}];
step[2] = {
   {color[2], EdgeForm[Black], Polygon[mid]},
   {step[1], right2, left2}
   };
Graphics[step[2]]

enter image description here

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[3] = LightBlue;
color[4] = LightGreen;
color[n_] := Lighter[ColorData[1][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]]

enter image description here

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:

enter image description here


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]

enter image description here

The obvious difference is that this image is triangular, growing the way we expect a CA to grow.

$\endgroup$
  • $\begingroup$ 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 $\endgroup$ – Yuriy S Sep 29 '16 at 6:21

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.