Eye of Ra :ellipse_self_similar

[Roger Bagula]

http://www.geocities.com/rlbagulatftn/ellipse_self_similar.jpg

I orginially did this in the 60's inspired by the CBS logo of a eye.
This is the first time I figured out a mathematical form for a
self-similar ellipse of thios sort:
The figure alternates ellipses and inscribed ellises.
It also tiles a disk in an hyperbolic reduction scaling of scale of
powers of two.
I really doubt this is a new fractal, but it is pretty anyway.
I call it the "Eye of Ra" as
reading about Akhenaten made me think of it.
Mathematica:
Clear[x, y, i, t, g]
x[i_, t_] = If[Mod[i, 2] == 0, Cos[t]/2^(i - 1), Cos[t]/2^i]
y[i_, t_] = If[Mod[i, 2] == 0, Sin[t]/2^(i + 1), Sin[t]/2^i]
g = Table[ParametricPlot[{x[i, t], y[i, t]}, {t, -
Pi, Pi}, Axes -> False], {i, 0, 10}]
Show[g, PlotRange -> All]

Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html
alternative email: rlba...@sbcglobal.net

[Roger Bagula]

http://local.wasp.uwa.edu.au/~pbourke/fractals/trianguloid/
http://www.geocities.com/rlbagulatftn/trianguloid_ifs.gif
Mathematica:
Clear[f, dlst, pt, cr, ptlst, x, y]
dlst = Table[ Random[Integer, {1, 3}], {n, 50000}];
f[1, {x_, y_}] := N[ {2*x*y/(x2 + y2) , (y2 - x2)/(y2 + x2)}];

f[2, {x_, y_}] := N[ {2/(x + 2) - 1, 2/(y + 2) - 1}];

f[3, {x_, y_}] := N[ {-(y2 - x2)/(y2 + x2), 2*x*y/(x2 + y2) }];

pt = {0.5, 0.75};

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[Join[{PointSize[.001]},
ptlst]], AspectRatio -> Automatic, PlotRange -> All]

[Roger Bagula]

A cantor staircase standing wave fractal:
http://www.flickr.com/photos/fractalmusic/3682265002/

Mathematica:
Clear[f, dlst, pt, cr, ptlst, x, y]

(* phase locking Cantor staircase function : http : // \
mathworld.wolfram.com/DevilsStaircase.html*)
f0[{omega_, t_}] := {omega, t + omega - Sin[2Pi t]/(2Pi)};
WindingNumber[n_, {omega_, t_}] := (Nest[f0, {omega, t}, n][[2]] - t)/n;
dlst = Table[ Random[Integer, {1, 3}], {n, 100000}];

f[1, {x_, y_}] := N[ {2*x*y/(x2 + y2) , (y2 - x2)/(y2 + x2)}];

f[2, {x_, y_}] := N[ {WindingNumber[2, {y, x}], WindingNumber[2, {x, y}]}];

[Roger Bagula]

http://www.geocities.com/rlbagulatftn/eyeofra_ifs.gif
The Eye of Ra fractal
by doing an affine inside the
kiss ellipse with reduced the number of transforms in

Mathematica:
Clear[f, dlst, pt, cr, ptlst, x, y]

RandomSeed[];
dlst = Table[ Random[Integer, {1, 2}], {n, 100000}];
f[1, {x_, y_}] := N[ {2*x*y/(x^2 + y^2) , (y^2 - x^2)/(y^2 + x^2)}];
f[2, {x_, y_}] := N[ {(2*((x - y)/
Sqrt[2]) - (x + y)/Sqrt[2])/(
2.83), (2*((x - y)/Sqrt[2]) + (x + y)/Sqrt[2])/(2.83)}];
pt = {0.5, 0.75};
cr[n_] := If[n - 2 == 0, RGBColor[
0, 0, 1], If[n - 3 == 0, RGBColor[0,
1, 0], If[n - 1 == 0, RGBColor[1, 0, 0], RGBColor[0, 0, 0]]]]

[Roger Bagula]

http://www.flickr.com/photos/fractalmusic/3684969722/
A third elliptical fractal tiling type:
the ellipse kisses the previous scale and is rotated slightly.

Mathematica:
Clear[f, dlst, pt, cr, ptlst, x, y]

dlst = Table[ Random[Integer, {1, 3}], {n, 100000}];
f[1, {x_, y_}] := N[ {2*x*y/(x2 + y2) , (y2 - x2)/(y2 + x2)}];

f[2, {x_, y_}] := N[ {(2*x - y)/(2.83), (2*x + y)/(2.83)}];

[John Fultz]

On Sat, 4 Jul 2009 06:43:42 -0400 (EDT), Roger Bagula wrote:
> http://www.geocities.com/rlbagulatftn/eyeofra_ifs.gif
>
> The Eye of Ra fractal
> by doing an affine inside the
> kiss ellipse with reduced the number of transforms in

> Mathematica:
> Clear[f, dlst, pt, cr, ptlst, x, y]

> RandomSeed[];
> dlst = Table[ Random[Integer, {1, 2}], {n, 100000}];
> f[1, {x_, y_}] := N[ {2*x*y/(x^2 + y^2) , (y^2 - x^2)/(y^2 + x^2)}];
> f[2, {x_, y_}] := N[ {(2*((x - y)/
> Sqrt[2]) - (x + y)/Sqrt[2])/(
> 2.83), (2*((x - y)/Sqrt[2]) + (x + y)/Sqrt[2])/(2.83)}];

> pt = {0.5, 0.75};
> cr[n_] := If[n - 2 == 0, RGBColor[
> 0, 0, 1], If[n - 3 == 0, RGBColor[0,
> 1, 0], If[n - 1 == 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[Join[{PointSize[.001]}, ptlst]],
> AspectRatio -> Automatic, PlotRange -> All]

New to version 7, when doing lists of multi-color points, it's much better to
use a multi-Point primitive with the VertexColors option. Here's an example of
your code refactored (also used FoldList rather than your history-remembering
global variable, which also adds a small speedup). I think you'll find this
rendering significantly faster.

Clear[f, dlst, pt, cr, ptlst, x, y];
RandomSeed[];
dlst = Table[Random[Integer, {1, 2}], {n, 100000}];
f[{x_, y_}, 1] := N[{2*x*y/(x^2 + y^2), (y^2 - x^2)/(y^2 + x^2)}];
f[{x_, y_}, 2] :=
N[{(2*((x - y)/Sqrt[2]) - (x + y)/
Sqrt[2])/(2.83), (2*((x - y)/Sqrt[2]) + (x + y)/
Sqrt[2])/(2.83)}];
cr[n_] :=
If[n - 2 == 0, RGBColor[0, 0, 1],
If[n - 3 == 0, RGBColor[0, 1, 0],
If[n - 1 == 0, RGBColor[1, 0, 0], RGBColor[0, 0, 0]]]];
ptlst = {PointSize[.001],
Point[Rest[FoldList[f, {.5, .75}, dlst]],
VertexColors -> cr /@ dlst]};

Show[Graphics[Join[{PointSize[.001]}, ptlst]],
AspectRatio -> Automatic, PlotRange -> All]

Sincerely,

John Fultz
jfu...@wolfram.com
User Interface Group
Wolfram Research, Inc.

[Yves Klett]

John,

VertexColors and Multi-Primitives certainly come in handy and offer new
effective approaches to complex visualization.

But... it is quite vexing that the old-fashioned code is rendered so
much slower (whatever the reasons).

Many users are not aware of the new approach for larger primitive sets,
and it is not very handy to have to re-write "old" code to get it to run
adequately fast. In my case, I often postprocess the "old" output into
multi-primitives (plus VertexColors) and then render them. But this is
not always trivial, and might put new users off (or have them complain
about bad performance, never a nice thing).

Since the rendering can be slowed down (or accelerated, depending on
where you stand) significantly, perhaps it would be nice if Mathematica
took care of that optimization internally and save the user the hassle.

Is there any intent at WRI to get over this issue (e.g. by transparently
preprocessing the output before rendering without changing the structure
of the graphics expression in the notebook) or will we have to get used
to this split approach and code accordingly?

Kind regards,
Yves

John Fultz schrieb:

[Roger Bagula]

http://www.geocities.com/rlbagulatftn/op_eye_ifs.gif
Another of the nested ellipse types that I found yesterday.
A very simple op art type tiling of a circle:

Clear[f, dlst, pt, cr, ptlst, x, y]

dlst = Table[ Random[Integer, {1, 2}], {n, 250000}];
f[1, {x_, y_}] := N[{-x/2 - y/2, x/2 - y/2 + 7/24}];
f[2, {x_, y_}] := N[ {2*x*y/(x2 + y2) , (x2 - y2)/(y2 + x2)}];
pt = {0.5, 0.75};
cr[n_] := If[n - 1 == 0, RGBColor[0, 0, 1], If[n - 2 ==
0, RGBColor[0, 0, 0], If[n - 3 == 0, RGBColor[1, 0, 0], RGBColor[0, 1, 0]]]]

[Roger Bagula]

http://www.geocities.com/rlbagulatftn/fractal_teardrops.gif
I was wondering if I could do the self-similar trick with othher figures
besides ellipses and circles and
I remembered the teardrop or piriform shape:

Clear[f, dlst, pt, cr, ptlst, x, y]

RandomSeed[];

dlst = Table[ Random[Integer, {1, 2}], {n, 250000}];
f[1, {x_,

y_}] := N[ {((
x^2 - y^2)/(y^2 + x^2))^2*2*x*y/(x^2 + y^2) , (x^2 - y^2)/(
y^2 + x^2)}];
f[2, {x_, y_}] := N[{7/24 - x/2 - y/2, x/2 - y/2}];
pt = {0.5, 0.75};
cr[n_] := If[n - 2 == 0, RGBColor[0, 0, 1], If[n - 3 == 0, RGBColor[0, 1,
0], If[n - 1 == 0, RGBColor[1, 0, 0], RGBColor[0, 0, 0]]]]

[Roger Bagula]

http://www.geocities.com/rlbagulatftn/limacon_kiss.gif
So far there are four working parametric ifs projection types:
circle-ellipse
piriform-drop
lemniscape
limacon

There are two ways to get a kissing Limacon:
inner and outer:
Mathematica:

Clear[f, dlst, pt, cr, ptlst, x, y]
RandomSeed[];
dlst = Table[ Random[Integer, {1, 2}], {n, 250000}];
f[1, {x_,

y_}] := N[ {(1 - 2*(x2 - y2)/(y2 + x2))*2*x*y/(x2 + y2) , (
1 - 2*(x2 - y2)/(y2 + x2))*(x2 - y2)/(y2 + x2)}];
f[2, {x_, y_}] := N[{-x/(1/0.085) - y/((1/0.085)), -1/2 + x/((1/0.085))
- y/(
1/0.085)}];

pt = {0.5, 0.75};
cr[n_] :=
If[n - 2 == 0, RGBColor[0, 0, 1], If[n - 3 == 0, RGBColor[0, 1,
0], If[n - 1 == 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[Join[{PointSize[.001]}, ptlst]],
AspectRatio -> Automatic, PlotRange -> All]

http://www.geocities.com/rlbagulatftn/limacon_2ndkiss.gif
MATHEMATICA:

Clear[f, dlst, pt, cr, ptlst, x, y]
RandomSeed[];

dlst = Table[ Random[Integer, {1, 2}], {n, 100000}];
f[1, {x_,
y_}] := N[ {(1 - 2*(x2 - y2)/(y2 + x2))*2*x*y/(x2 + y2) , (
1 - 2*(x2 - y2)/(y2 + x2))*(x2 - y2)/(y2 + x2)}];
f[2, {x_, y_}] := N[{-
x/(1/0.255) - y/(1/0.255), -1/2 + x/(1/0.255) - y/(1/0.255)}];

pt = {0.5, 0.75};
cr[n_] := If[
n - 2 == 0, RGBColor[0, 0, 1], If[n - 3 == 0, RGBColor[0, 1, 0],
If[n - 1 == 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[Join[{PointSize[.001]}, ptlst]],
AspectRatio -> Automatic, PlotRange -> All]

http://www.geocities.com/rlbagulatftn/lemniscape_kiss_iff.gif
A kissing lemniscape fractal ifs:
Mathhematica:

Clear[f, dlst, pt, cr, ptlst, x, y]
RandomSeed[];
dlst = Table[ Random[Integer, {1, 2}], {n, 250000}];
f[1, {x_,

y_}] := N[ {Sqrt[Abs[(((2*x)2 - (2*y)2)/((2*y)2 + (2*x)2))]]*2*x*y/(
x2 + y2) , Sqrt[Abs[(((2*x)2 - (2*y)2)/((2*y)2 + (2*
x)2))]]*(x2 - y2)/(y2 + x2)}];
f[2, {x_, y_}] := N[{-x/(1/0.370) - y/(1/0.370), 1/2 +
x/(1/0.370) - y/(1/0.370)}];