Re: color assignment in an Mathematica IFS
- To: mathgroup at smc.vnet.net
- Subject: [mg79345] Re: [mg79324] [mg79324] color assignment in an Mathematica IFS
- From: Daniel Lichtblau <danl at wolfram.com>
- Date: Wed, 25 Jul 2007 02:07:28 -0400 (EDT)
- References: <200707241012.GAA26515@smc.vnet.net>
Roger Bagula wrote:
> A problem that was partially solved by Bob Hanlon in a
> post a while back on color in IFS.
> The Wellin type IFS in Mathematica or the McClure digraph method
> are both black and white. I do a lot of work on IFS fractals of
> different types.
> I found a dreadfully slow Do loop code that maybe someone
> can speed up.
> I put a color privative in a point array, so that the point comes out
> having color.
> I make a "data structure" of color and Point.
> I found the starting Mathematica code at Dr. Frame's ( the Mandelbrot
> course at Yale)
> web pages.
> Mathematica:
> (* from Symbol Driven IFS - Four Bins : Dr. Frame - Yale *)
>
> Off[General::spell];
>
> Off[General::spell1];
>
> (* Random table on {1, 2, 3, 4}*)
> dlst = Table[Random[Integer, {1, 4}], {n, 10000}];
> Length[dlst]
> (* paste the data between the {} in dlst = {}, comma separated
> numbers, 1 through 4 *)
> (*Sierpinski space fill in four squares*)
> f[1, x_, y_] := {0.5*x, 0.5*y}
>
> f[2, x_, y_] := {0.5*x + 0.5, 0.5*y}
>
> f[3, x_, y_] := {0.5*x, 0.5*y + 0.5}
>
> f[4, x_, y_] := {0.5*x + 0.5, 0.5*y + 0.5}
>
> ptlst = {PointSize[.01]};
>
> pt = {0.5, 0.5};
>
> (* color privative assignment function*)
> cr[n_] := If[n - 1 == 0, RGBColor[0, 0, 1], If[n - 2 == 0, RGBColor[0,
> 1, 0],
> If[n - 3 == 0, RGBColor[1, 0, 0], RGBColor[0, 0, 0]]]];
> (* color, Point structure Do loop iterated: instead of the Nest usually
> used in the Wellin code*)
> Do[{x = pt[[1]], y =
> pt[[2]], pt[[1]] = f[dlst[[j]], x, y][[1]], pt[[2]] = f[dlst[[j]], x,
> y][[2]], ptlst = Flatten[{ptlst, cr[dlst[[j]]],
> Point[pt]}]}, {j, 1, Length[dlst]}]
>
> Show[Graphics[ptlst], AspectRatio -> Automatic, PlotRange -> All]
The primary bottleneck is in the iterative flattening of a growing list,
inside the loop. This in effect makes it a nested loo, taking complexity
from O(n) to O(n^2). The code below is probably equivalent and should be
reasonably fast.
dlst = RandomInteger[{1,4}, {10000}];
f[j_,{x_,y_}] := 0.5*{x,y} + 0.5*Reverse[IntegerDigits[j-1,2,2]]
pt = {0.5, 0.5};
cr[n_] := RGBColor[Sequence[Drop[RotateLeft[{0,0,0,1},n-1],1]]]
ptlst = Table[{cr[dlst[[j]]],Point[pt=f[dlst[[j]],Sequence[pt]]]},
{j,Length[dlst]}];
Show[Graphics[ptlst], AspectRatio -> Automatic, PlotRange -> All]
Daniel Lichtblau
Wolfram Research
- References:
- color assignment in an Mathematica IFS
- From: Roger Bagula <rlbagula@sbcglobal.net>
- color assignment in an Mathematica IFS