AMERICAN MATHEMATICAL MONTHLY -April 2009:Transformations Between Self-Referential Sets]

[Roger Bagula]

=>(second post : first one didn't show up)
I haven't had fun like this since I typed in Barnley's original Byte
article IFS's.
The Fern just blew me away
back then! Today this affine rearranged Sierpinski gasket is great work.
Loading Image...
Loading Image...
Loading Image...

http://www.maa.org/pubs/monthly_apr09_toc.html
April 2009
Transformations Between Self-Referential Sets
By: Michael F. Barnsley
***@aol.com
Did you know that there are continuous transformations from a fractal
fern onto a filled square? Also, there are functions of a similar wild
character that map from a filled triangle onto itself. We prove that
these fractal transformations may be homeomorphisms, under simple
conditions, and that they may be calculated readily by means of a
coupled Chaos Game. We illustrate several examples of these beautiful
functions and show how they exemplify basic notions in topology,
probability, analysis, and geometry. Thus they are worthy of the
attention of the mathematics community, both for aesthetic and
pedagogical reasons.

Mathematica:
Clear[f, dlst, pt, cr, ptlst, M, p, a, b, c]
n0 = 3;
dlst = Table[ Random[Integer, {1, n0}], {n, 100000}];
a = 0.65; b = 0.3; c = 0.4;
M = {{{-1 + b, -1/2 + b/2 + a/2}, {0, a}}, {{b + c/
2 - 1/2, b/2 - c/4 + 1/4}, {1 - c, c/2 - 1/2}}, {{c/2, -1/2 + a/2 - \
c/4}, {-c, -1 + a + c/2}}, {{b + c/2 - 1/2, -3/4 + b/4 + a/2 - 1/4}, {
1 - c, a - 1/2 - c/4}}}
in = {{1 - b, 0}, {1 - b, 0}, {1/2, 1}, {1 - b, 0}};
Length[in]
f[j_, {x_, y_}] := M[[j]]. {x, y} + in[[j]]
pt = {0.5, 0.5};
cr[n_] := Flatten[Table[If[i == j == k == 1, {}, RGBColor[i, j, k]], {i, 0,
1}, {j, 0, 1}, {k, 0, 1}]][[1 + Mod[n, 7]]];
ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];
Show[Graphics[Join[{PointSize[.001]},
ptlst[n]]], AspectRatio -> Automatic, PlotRange -> All]

[Roger Bagula]

Besides the Sierpinski gasket
a=b=c=1/2
special symmetrical form
there is this one
a=b=c=1/3
and the
a=b=c=2/3
with is the same one rotated.

Loading Image...

Clear[f, dlst, pt, cr, ptlst, M, p, a, b, c, x0, x, y]
n0 = 3;
dlst = Table[ Random[Integer, {1, n0}], {n, 250000}];
rotate[theta_] := {{Cos[theta], -Sin[theta]}, {Sin[theta], Cos[theta]}};
a = b = c = N[1/3]
M = {{{-1 + b, -1/2 + b/2 + a/2}, {0, a}}, {{b + c/2 - 1/2,
b/2 - c/4 + 1/4}, {1 - c, c/2 - 1/2}}, {{c/2, -1/2 + a/
2 - c/4}, {-c, -1 + a + c/2}}}
a0 = Table[Det[M[[i]]], {i, 1, 3}]
Apply[Plus, a0]
in = {{1 - b, 0}, {1 - b, 0}, {1/2, 1}};
Length[in]
f[j_, {x_, y_}] := M[[j]]. {x, y} + in[[j]]
pt = {0.5, 0.5};
cr[n_] := Flatten[Table[If[i == j == k == 1, {}, RGBColor[i, j, k]], {
i, 0, 1}, {j, 0, 1}, {k, 0, 1}]][[1 + Mod[n, 7]]];
ptlst[n_] := Table[{cr[dlst[[j]]], Point[pt = f[dlst[[j]], Sequence[pt]]]},
{j, Length[dlst]}];
Show[Graphics[Join[{PointSize[.001]}, ptlst[n]]], AspectRatio ->
Automatic, \
PlotRange -> All]