10
$\begingroup$

I'm generating the Sierpinski Gasket by implementing a chaos game in Mathematica. What I'd like to do is create an interactive manipulation with a slider, whereby moving it forward, plots all the points produced at each level of iteration (described in the code below). I'd also like to associate each point with a color depending on the affine transformation that was used to produce it. There are three affine transformations being used for this iterated function system $W_{1},W_{2},W_{3}$. So, if a point was produced using $W_{1}$, I'd like to color it red. If a point was produced with $W_{2}$, then color it blue, and so on. How would I go about doing this, preferrably using the code I've concocted thus far?

enter image description here

Here is the code I've made thus far:

Clear[A, B, W, X, i, ITERATIONS, roll]

(* Transformation matrices A[i] given below *)
A[1] = {{0.5, 0}, {0, 0.5}};
A[2] = {{0.5, 0}, {0, 0.5}};
A[3] = {{0.5, 0}, {0, 0.5}};

(* Translation vectors B[i] are defined below *)
B[1] = {0, 0};
B[2] = {1/2, 0};
B[3] = {1/4, Sqrt[3]/4};

(* Format of affine Transformation *)
W[i_, X_] := A[i].X + B[i]

RandomComponent := Random[Real, {0, 1}];

(* Initial point within bounds of unit square *)

X[0] = {RandomComponent, RandomComponent};

(* Iteration Process is defined here:
At each level of iteration we roll a standard dice. Depending on the outcome, we apply one of the affine transformations defined above to the point provided  during the previous level of iteration *)

ITERATIONS = 100000;
X[i_] = For[i = 0, i <= ITERATIONS, i++, 
  roll = Random[Integer, {1, 6}];

  If[roll == 1 || roll == 2,

   X[i + 1] = W[1, X[i]],

   If[roll == 3 || roll == 4,

    X[i + 1] = W[2, X[i]],

    If[roll == 5 || roll == 6,

     X[i + 1] = W[3, X[i]]]]]]

fractal1 = Table[X[n], {n, 1, ITERATIONS}];


ListPlot[fractal1, Axes -> False, AspectRatio -> Automatic, 
 PlotStyle -> {PointSize[0.001]}]


UPDATE 1 (Code for interactive plot): Here is the code for interactively plotting the Sierpinski Triangle via a Random Iterated Function System. The coloring aspect is still something I'm trying to work on as I wrangle through J.M.'s code. I was already aware of the affine transform and nested list functionality, but for the sake of my audience, I didn't resort to using it until now. The RandomChoice function has been very useful, credits to J.M. for pointing this out.

Clear[W, W1, W2, W3, P1, P2, P3, X, n, x]

(* The Affine Transformations *)

W1 = AffineTransform[{{{0.5, 0}, {0, 0.5}}, {0, 0}}];
W2 = AffineTransform[{{{0.5, 0}, {0, 0.5}}, {1/2, 0}}];
W3 = AffineTransform[{{{0.5, 0}, {0, 0.5}}, {1/4, Sqrt[3]/4}}];

(* Their Associated Probabilities (weights) *)
P1 = 0.33;
P2 = 0.33;
P3 = 0.34;

RandomComponent := Random[Real, {0, 1}];

(* Produces Initial Point *)
X[0] := {RandomComponent, RandomComponent}

(* Chooses Affine Transformations according to their weights *)

RandomChoice[{P1, P2, P3} -> {W1, W2, W3}];

(* Applies selected transformation to given point *)

W[x_] := RandomChoice[{P1, P2, P3} -> {W1, W2, W3}][x];

(* NestedList provides us with a way of collecting the output from iterating W[x_] *)

Clear[n]
Animate[ListPlot[BlockRandom[NestList[W, X[0], n]], Axes -> False, 
  AspectRatio -> Automatic, PlotStyle -> {PointSize[0.006]}, 
  PlotRange -> {{0, 1}, {-0.09, 1}}], {n, 0, 10000, 1}, 
 DisplayAllSteps -> True, AnimationRunning -> False, 
 AnimationRate -> 1000]

X[0];

The result is:

enter image description here

$\endgroup$

2 Answers 2

16
$\begingroup$

As I understand it, you'd like to dynamically illustrate how the chaos game works by showing how the points arise randomly. Here are two approaches, with enough code in common that we can practically do them both at once.

Using Dynamic

First, I think it's quite natural to do this with Dynamic. To do so, we set up an image called dynamicPic that we'll subsequently modify.

dynamicPic = pic[0] = Graphics[{},
  PlotRange -> {{0, 1}, {0, 1}},
  Axes -> True
];
Dynamic[dynamicPic]

You should see just a pair of axes spanning the unit square. (The pic[0] is not relevant until we see the second solution.) Next, we'll modify dynamicPic in a loop and watch the image change. To do so, just execute the following, perhaps in a second notebook that doesn't cover the original image.

If[!MemberQ[$ContextPath,"Internal`"],
  AppendTo[$ContextPath,"Internal`"]
];
Clear[pic, dynamicPic];
f[1] = #/2&;
f[2] = #/2+{1/2,0}&;
f[3] = #/2+{1/4,Sqrt[3]/4}&;
Do[bag[i]=Bag[],{i,1,3}];
SeedRandom[1];
pt = RandomReal[{0,1},{2}];
Do[
  j = RandomInteger[{1,3}];
  pt = f[j][pt];
  StuffBag[bag[j], pt];
  dynamicPic = pic[k] = Graphics[
    Table[{ColorData[1,i], PointSize[Tiny], 
      Point@BagPart[bag[i],All]},{i,1,3}],
    PlotRange -> {{0,1},{0,1}},Axes -> True
  ],{k,1,10000}
];//AbsoluteTiming

Now, the output from the previously executed Dynamic[dynamicPic] should start to change. It takes around 13 seconds on my machine to generate and display all 10000 images. The process slows down as it progresses, since the whole image is displayed with each iteration. In this sense, the process is very different from drawing to a canvas as we see in many GUI type languages.

Using Animate

In the previous example, at each step we defined pic[k], in addition to overwriting dynamicPic. With the images generated we can now pass the result to Animate

Animate[pic[k], {k, 0, 10000, 1}]

Some Comments

Point[{{_,_}..}] is generally much faster than {Point[{_,_}]..}. This so-called "multi-point" syntax was introduced in V6. It can be trickier to work with though. In this example, I used Bag from the Internal context (which feels a lot like a stack) to build three lists of points for each of the colors.

I'm not a big fan of AffineTransform and friends. On the contrary, these functions seem to be a huge disappointment. They're kind of nice when you want to illustrate the effect of an affine transformation on an image in, say, a linear algebra class. But, if you know how to work with Graphics primitives, then it seems quite easy to roll your own and this will likely be more flexible.

Finally, I've written a package that you can grab off of my webspace that expands to a set of packages and documentation notebooks. Using the IteratedFunctionSystems package, Barnsley's fern can be generated quite quickly like so:

barnsleyFernIFS = {
  {{{.85, .04}, {-.04, .85}}, {0, 1.6}},
  {{{-.15, .28}, {.26, .24}}, {0, .44}},
  {{{.2, -.26}, {.23, .22}}, {0, 1.6}},
  {{{0, 0}, {0, .16}}, {0, 0}}
};
ShowIFSStochastic[
  barnsleyFernIFS, 70000,
  Colors -> {Darker[Green, 0.6], Darker[Green, 0.4],
    Darker[Green, 0.4], Black}]

enter image description here

Note that good probabilities are chosen automatically and that an image with 70000 points is generated in about half a second.

As another example, here's another way that one might interact with the Sierpinski triangle:

A = {{1, 0}, {0, 1}}/2;
Manipulate[
  ShowIFS[{{A, pt1/2}, {A, pt2/2}, {A, pt3/2}}, 8, 
    PlotRange -> {{-0.1, 1.1}, {-0.1, 1.1}}, Colors -> True,
    Initiator -> {PointSize[Small], Point[{0, 0}]}],
  {pt1, {0, 0}, {1, 1}, Locator}, 
  {{pt2, {1, 0}}, {0, 0}, {1, 1}, Locator}, 
  {{pt3, {1/2, Sqrt[3]/2}}, {0, 0}, {1, 1}, Locator}]

enter image description here

$\endgroup$
4
  • $\begingroup$ Excellent and thorough example, thank you. $\endgroup$
    – Black Milk
    Commented Jun 25, 2013 at 17:20
  • $\begingroup$ @MarkMcClure: are the links to the webpage and zip file no longer active? $\endgroup$
    – Moo
    Commented Aug 27, 2016 at 13:51
  • $\begingroup$ @Moo Those packages are (now) available here: marksmath.org/FractalGeometryPackages.zip $\endgroup$ Commented Aug 28, 2016 at 16:00
  • $\begingroup$ @MarkMcClure: Thank you for posting those! $\endgroup$
    – Moo
    Commented Aug 28, 2016 at 16:16
6
$\begingroup$

Maybe you can consider a solution like this instead?

newPoint[{col_, Point[pt_]}] := Block[{nc, tr},
   {nc, tr} =
   (* use RandomChoice to pick an affine transformation and its corresponding color *)
   RandomChoice[{{Red, AffineTransform[{{{0.5, 0}, {0, 0.5}}, {0, 0}}]},
                 {Green, AffineTransform[{{{0.5, 0}, {0, 0.5}}, {1/2, 0}}]},
                 {Blue, AffineTransform[{{{0.5, 0}, {0, 0.5}}, {1/4, Sqrt[3]/4}}]}}];
   {nc, Point[tr[pt]]}]

With[{n = 5*^3}, (* number of iterations *)
     BlockRandom[SeedRandom[42, Method -> "MersenneTwister"]; (* for reproducibility *)
     Graphics[{AbsolutePointSize[1/4], 
               NestList[newPoint,
                        {Black, Point[RandomReal[{0, 1}, 2]]} (* starting point *),
                        n]}, 
              Frame -> True]]]

IFS Sierpinski gasket


To demonstrate another way to color points from different affine transformations, and to also demonstrate the flexibility of RandomChoice[] in supporting probabilities, I'll use Barnsley's fern as an example here:

newPoint[{idx_, pt_?VectorQ}] := Block[{nc, tr},
   {nc, tr} = 
   RandomChoice[{0.85, 0.07, 0.07, 0.01} ->
                {{1, AffineTransform[{{{0.85, 0.04}, {-0.04, 0.85}}, {0, 1.6}}]},
                 {2, AffineTransform[{{{0.2, -0.26}, {0.23, 0.22}}, {0, 1.6}}]},
                 {3, AffineTransform[{{{-0.15, 0.28}, {0.26, 0.24}}, {0, 0.44}}]},
                 {4, AffineTransform[{{{0, 0}, {0, 0.16}}, {0, 0}}]}}];
   {nc, tr[pt]}]

With[{n = 1*^4},
     BlockRandom[SeedRandom[42, Method -> "MersenneTwister"];
     Graphics[{AbsolutePointSize[1/4], 
               MapIndexed[{Extract[{Black, Green, Blue, Cyan, Yellow}, #2],
                           Point[Last /@ #1]} &, 
                          GatherBy[SortBy[NestList[newPoint, {0, {0, 0}}, n],
                                   First], First]]},
              Frame -> True]]]

Barnsley's fern

$\endgroup$
5
  • $\begingroup$ this looks nice, but there may be occasions where I don't want to merely randomly choose a transformation to apply. For example, with an iterated function system for a fern fractal, some of the affine transformations involved are use mored often than others. I will update my question to demonstrate what I mean. Also, your solution doesn't provide a method for interactively manipulating the plot with a slider. $\endgroup$
    – Black Milk
    Commented May 21, 2013 at 18:16
  • 1
    $\begingroup$ @Edwin, RandomChoice[] supports weights; look this up in the docs. So, you can still do Barnsley's fern with this approach. You also shouldn't have any difficulty modifying this to use a slider for n instead of the With[{n = bignumber}, (* stuff *)] in my code. $\endgroup$ Commented May 21, 2013 at 18:23
  • $\begingroup$ Well this looks very handy, thanks. I'll see how it works and post my results. $\endgroup$
    – Black Milk
    Commented May 21, 2013 at 18:32
  • $\begingroup$ I'm having a difficult time digesting the code within With[...]. I understand what you're doing with nestedlist,affine transform, and the randomchoice[] is excellent. But I'm just not really parsing the rest. Could you elaborate on it some more? Thank you. I've updated my question with code for an interactive plot of the fractal. $\endgroup$
    – Black Milk
    Commented May 22, 2013 at 0:08
  • $\begingroup$ @Edwin, can you be a bit more specific in what section(s) of the code are giving you difficulty? Also, did you at least try to look up functions unfamiliar to you in the docs? $\endgroup$ Commented May 22, 2013 at 0:57

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.