Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

share|improve this question

2 Answers 2

up vote 5 down vote accepted

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 number of Fractal related packages, which you can grab off of my Mathematica page; specifically, you can grab this zip file 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

share|improve this answer
    
Excellent and thorough example, thank you. –  Black Milk Jun 25 '13 at 17:20

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

share|improve this answer
    
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. –  Black Milk May 21 '13 at 18:16
1  
@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. –  J. M. May 21 '13 at 18:23
    
Well this looks very handy, thanks. I'll see how it works and post my results. –  Black Milk May 21 '13 at 18:32
    
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. –  Black Milk May 22 '13 at 0:08
    
@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? –  J. M. May 22 '13 at 0:57

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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