Mathematica - color assignment in an Mathematica IFS

Author

color assignment in an Mathematica IFS

Roger Bagula

2007-07-24, 8:15 am

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]

Daniel Lichtblau

2007-07-25, 4:28 am

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

Roger Bagula

2007-07-27, 8:14 am

Daniel Lichtblau wrote:

>
>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
>
>
>

Daniel Lichtblau
Wolfram Research

Thanks.
This works very fast here:

Clear[f, dlst, pt, cr, ptlst]
dlst = Table[ Random[Integer, {1, 4}], {n, 10000}];
f[j_, {x_, y_}] := 0.5*{x, y} + 0.5*Reverse[IntegerDigits[j - 1, 2, 2]]

pt = {0.5, 0.5};

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]]]]
ptlst = Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];

Show[Graphics[ptlst], AspectRatio -> Automatic, PlotRange -> All]

I think you are going to save me a lot of time.
Roger Bagula

Daniel Lichtblau

2007-07-28, 8:12 am

Roger Bagula wrote:
> Daniel Lichtblau wrote:
>
>
>
>
>
>
> Daniel Lichtblau
> Wolfram Research
>
> Thanks.
> This works very fast here:
>
> Clear[f, dlst, pt, cr, ptlst]
> dlst = Table[ Random[Integer, {1, 4}], {n, 10000}];
> f[j_, {x_, y_}] := 0.5*{x, y} + 0.5*Reverse[IntegerDigits[j - 1, 2, 2]]
>
> pt = {0.5, 0.5};
>
> 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]]]]
> ptlst = Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
> {j, Length[dlst]}];
>
> Show[Graphics[ptlst], AspectRatio -> Automatic, PlotRange -> All]
>
> I think you are going to save me a lot of time.
> Roger Bagula

Hre is a corrected form as compared to what I sent earlier. It is also
slightly faster.

cr[1] = RGBColor[0, 0, 1];
cr[2] = RGBColor[0, 1, 0];
cr[3] = RGBColor[1, 0, 0];
cr[4] = RGBColor[0, 0, 0];

dlst = RandomInteger[{1, 4}, {10^4}];

f[j_, x_, y_] :=
0.5*{x, y} + 0.5*Reverse[IntegerDigits[j - 1, 2, 2]];

pt = {0.5, 0.5};

ptlst = Table[{cr[dlst[[j]]],
Point[pt = f[dlst[[j]], Apply[Sequence, pt]]]},
{j,Length[dlst]}];]

Daniel Lichtblau
Wolfram Research

Sponsored Links