Manipulating plot of random iterated function system fractal
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}]
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}]
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]]]
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]]]