Re: Iterated Function System
- To: mathgroup at smc.vnet.net
- Subject: [mg67717] Re: Iterated Function System
- From: Roger Bagula <rlbagula at sbcglobal.net>
- Date: Wed, 5 Jul 2006 04:18:46 -0400 (EDT)
- References: <e8d0uo$4dk$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
JAMES ROHAL wrote:
>I am looking for a faster way to plot Iterated Function Systems in Mathematica. Currently my method is using Barnsley's algorithm which randomly chooses a transformation and applies it to a previous point to get the next point. I then store the points in a list corresponding to the transformation that was applied to it. Is there a faster way to program this using functional programming in Mathematica? Thanks in advance.
>
><< Graphics`MultipleListPlot`
><< Graphics`Colors`
>
>steps = 30000;
>
>M = {{1/2, 0}, {0, 1/2}};
>T1[x_] := {{0}, {0}} + M.x;
>T2[x_] := {{1/2}, {0}} + M.x;
>T3[x_] := {{1/4}, {Sqrt[3]/4}} + M.x;
>
>zi = {{Random[]}, {Random[]}};
>T1listPoints = {};
>T2listPoints = {};
>T3listPoints = {};
>
>For[i = 1, i < steps, i++;
> rand = Random[Integer, {1, 3}];
> Switch[rand,
> 1, {zi = T1[zi], T1listPoints = Append[T1listPoints, Flatten[zi]]},
> 2, {zi = T2[zi], T2listPoints = Append[T2listPoints, Flatten[zi]]},
> 3, {zi = T3[zi], T3listPoints = Append[T3listPoints, Flatten[zi]]}
> ];
>];
>
>graph1 = ListPlot[T1listPoints, PlotStyle -> {PointSize[0.00001], RGBColor[1, 0, 0]}, DisplayFunction -> Identity];
>graph2 = ListPlot[T2listPoints, PlotStyle -> {PointSize[0.00001], RGBColor[0, 1, 0]}, DisplayFunction -> Identity];
>graph3 = ListPlot[T3listPoints, PlotStyle -> {PointSize[0.00001], RGBColor[0, 0, 1]}, DisplayFunction -> Identity];
>Show[{graph1, graph2, graph3}, DisplayFunction -> $DisplayFunction];
>
>James Rohal
>College of Wooster 2007
>
>
>
>
James Rohal,
I use two programs:
1) Wellin IFS
2) McClure digraph
The McClure is at:
http://facstaff.unca.edu/mcmcclur/mathematicaGraphics/
The Wellin program comes from one of his books.
Both share the problem your method does of having difficulty doing color.
Roger Bagula
(* minimal Pisot tile {2, 3] type definition in Mathematica*)
c = 0.868837;
a = 220.328;
r0 = c;
w0 = Pi*a/180
x0 = r0*Cos[w0];
y0 = r0*Sin[w0];
x5 = r0^3*Cos[3*w0];
y5 = r0^3*Sin[3*w0];
x3 = r0^2*Cos[2*w0];
y3 = r0^2*Sin[2*w0];
t = 1;
3.8454490343340666`
aa = (x*x5 - y*y5);
bb = (x*y5 + y*x5)
cc = Cos[t*Pi];
ss = Sin[t*Pi];
x1 = aa*cc - bb*ss + x5 + (x5)*t;
y1 = aa*ss + bb*cc + y5 - (x5)*t;
-0.5622809440406709` x + 0.33763880456792444` y
(* Wellin IFS program type*)
(* Akiyama_23 : curley tile*)
f1[{x_, y_}] = {x*x3 - y*y3 + x3, x3*y + y3*x + y3};
f2[{x_, y_}] = {x1, y1};
f[x_] := Which[(r = Random[]) <= 1/2, f1[x],
r <= 1.00, f2[x]]
ifs[n_] := Show[Graphics[{PointSize[.001],
Map[Point, NestList[f, {0, 0}, n]]}],
PlotRange -> All, AspectRatio -> Automatic]
ifs[20000]