 |
|
| Science Forum Index » Fractals Science Forum » hunting Herman's rings again... |
|
Page 1 of 1 |
|
| Author |
Message |
| Roger Bagula... |
 Posted: Tue Nov 03, 2009 4:17 am |
|
|
|
Guest
|
http://www.flickr.com/photos/fractalmusic/4071303229/
Looking back at an article I wrote about von Koch fractal drums
I found this by a slight modification to get unitary
singular points;
The funny thing about this polynomial set is that the fixed points are
related to Pisots:
f[z_,k_]=z2*(z + I)*(z - I)/((Sqrt[k - 1]*z/2 + Sqrt[5 - k]/2)*(-Sqrt
[k - 1]*z/2 + Sqrt[5 - k]/2))
when you take the toral inverse of that divide by z you get the
polynomial:
5*x3 - 4*x2 + x - 4
NSolve[5*x3 - 4*x2 + x - 4 == 0, x]
{{x -> -0.19690245698211484` - 0.794578922365906*I}, {x ->
-0.19690245698211484` + 0.794578922365906*I}, {x -
[quote]1.1938049139642297`}}
The Pisot constant:[/quote]
1.1938049139642297...
is about as low as some of the Salem constants;
http://www.cecm.sfu.ca/~mjm/Lehmer/lists/SalemList.html
between the second and third on the list.
The Herman's ring Julias of some of these polynomial are very
beautiful
fractal lace patterns:
Mathematica:
k = 8
g[z_] = z2*(z + I)*(z - I)/((
Sqrt[k - 1]*z/2 + Sqrt[5 - k]/2)*(-Sqrt[k - 1]*z/2 + Sqrt[5 - k]/
2))
(*Julia with Sqrt[x2+y2] limited measure*)
(*by R. L. BAGULA 2 Nov 2009© *)
numberOfz2ToEscape[z_] := Block[
{escapeCount, nz = N[z],nzold=0},
For[
escapeCount = 0,
(Sqrt[Re[nz]2+Im[nz]2] < 32) && (escapeCount < 512) && (Abs[nz-
nzold]>10^(-3)),
nzold=nz;
nz=g[nz];
++escapeCount
];
escapeCount
]
FractalPureM[{{ReMin_, ReMax_, ReSteps_},
{ImMin_, ImMax_, ImSteps_}}] : Table[
numberOfz2ToEscape[x + y I],
{y, ImMin, ImMax, (ImMax - ImMin)/ImSteps},
{x, ReMin, ReMax, (ReMax - ReMin)/ReSteps}
]
arraym=FractalPureM[{{-2,2,300},{-2,2,300}}];
ListDensityPlot[arraym,Mesh -> False,AspectRatio -> Automatic,
ColorFunction -> Hue, Axes -> False, Frame -> False, ImageSize ->
1000];
The number theory Mathematica is:
Table[ListPlot[Table[{Re[z], Im[z]} /. NSolve[z*(z + I)*(z - I) -
((Sqrt[k - 1]*z/2 + Sqrt[
5 - k]/2)*(-Sqrt[k - 1]*z/2 + Sqrt[5 - k]/
2)) == 0, z][[n]], {n, 1, 3}], PlotJoined ->
True, Axes -> False], {
k, 0, 10}]
Show[%]
Table[Table[Abs[z] /. NSolve[z*(z + I)*(z - I) - ((Sqrt[k - 1]*z/2 +
Sqrt[
5 - k]/2)*(-Sqrt[k - 1]*z/2 + Sqrt[5 - k]/2)) == 0, z][[n]],
{
n, 1, 3}], {k, 0, 10}]
f[z_] = z*(z + I)*(z - I) - ((Sqrt[
k - 1]*z/2 + Sqrt[5 - k]/2)*(-Sqrt[k - 1]*z/2 + Sqrt[5 - k]/2))
g[z_] = Expand[z3*f[1/z]]
Table[Table[Abs[z] /. NSolve[g[z] == 0, z][[n]], {n, 1, 3}], {k, 0,
10}]
Expand[4*g[z] /. k -> 0]
The interesting relationship of Pisot like sets to Herman's rings
ties in with the irrational numbers in Siegel disks.
Respectfully, Roger L. Bagula
11759 Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 :
http://www.google.com/profiles/Roger.Bagula
alternative email: roger.bagula at (no spam) gmail.com
Sequence related to this:
%I A167418
%S A167418
1,4,11,124,841,3844,23571,159164,903201,5174084,32096731,192836604,
%T A167418
1128271161,6758574724,40676603491,241740656444,1439437080721,
%U A167418
8616705389764,51443701799851,306634988322684,1830991983267881
%N A167418 A toral inverse expansion of the polynomial times 5^(n+1): p
(x)=5*x3 - 4*x2 + x - 4
%C A167418 Three comments:
%C A167418 1) the polynomial has a root near the second smallest Salem
number1.1883681475082235... at:
%C A167418 1.1938049139642297...
%C A167418 2) the signature sequences of the two constants to the 95th
term are the same:
%C A167418 A167289.
%C A167418 3) the limiting ratio of the terms
%C A167418 a[n+1]/a[n] approaches 5*1.1938049139642297....
%t A167418 Clear[p.q, x, t, n]
%t A167418 p[x_] = 5*x3 - 4*x2 + x - 4
%t A167418 q[x_] = 1/Expand[x3*p[1/x]]
%t A167418 Table[5^(n + 1)*SeriesCoefficient[ Series[q[t], {t, 0,
60}], n], {n, 0, 60}]
%Y A167418 A167289
%K A167418 nonn
%O A167418 0,2
%A A167418 Roger L. Bagula (rlbagulatftn(AT)yahoo.com), Nov 03 2009 |
|
|
| Back to top |
|
|
|
| Roger Bagula... |
| Posted: Sun Nov 08, 2009 9:05 am |
|
|
|
Guest
|
http://www.flickr.com/photos/fractalmusic/4086125589/
While I was hunting Herman's rings I realized that the resulting
function was very like the one Mandlelbrot quotes in his "The beauty
of Fractals' article
where I substitute for;
z2-1
the untitary function in k:(Sqrt[k - 1]*z/2 + Sqrt[5 - k]/2)*(-Sqrt[k
- 1]*z/2 + Sqrt[5 - k]/2)
At k=5 you get a very simple function:
f(z,c)=c*(-z-2/z-1/z3)
All the k results have the same two lobe shape inside a disk,
but the size varies.
Mathematica:
Clear[g, z, k, nz]
k = 5
g[z_] = ExpandAll[((z + I)*(z - I))2/(z*(Sqrt[k - 1]*z/2 + Sqrt[5 -
k]/2)*(-Sqrt[k - 1]*z/2 + Sqrt[5 - k]/2))]
(*Mandelbrot with Sqrt[x2+y2] limited measure*)
(*by R. L. BAGULA 8 Nov 2009© *)
numberOfz2ToEscape[z_] := Block[
{escapeCount, nz = N[z],nzold=0},
For[
escapeCount = 0,
(Sqrt[Re[nz]2+Im[nz]2] < 32) && (escapeCount < 512) && (Abs[nz-
nzold]>10^(-3)),
nzold=nz;
nz=z*g[nz];
++escapeCount
];
escapeCount
]
FractalPureM[{{ReMin_, ReMax_, ReSteps_},
{ImMin_, ImMax_, ImSteps_}}] : Table[
numberOfz2ToEscape[x + y I],
{y, ImMin, ImMax, (ImMax - ImMin)/ImSteps},
{x, ReMin, ReMax, (ReMax - ReMin)/ReSteps}
]
arraym=FractalPureM[{{-1.5001,1.5,300},{-1.5001,1.5,300}}];
gr=ListPlot3D[arraym, Mesh -> False,AspectRatio -> Automatic,Boxed-
[quote]False, Axes->False,AmbientLightRGBColor[0,0.25,0.25]];
ListDensityPlot[arraym,[/quote]
Mesh -> False,
AspectRatio -> Automatic,
ColorFunction->Hue,Axes->False,Frame->False];
Respectfully, Roger L. Bagula
11759 Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 :
http://www.google.com/profiles/Roger.Bagula
alternative email: roger.bagula at (no spam) gmail.com |
|
|
| Back to top |
|
|
|
| Roger Bagula... |
| Posted: Mon Nov 09, 2009 5:56 am |
|
|
|
Guest
|
Turning this kind of Lattes Mandlbrot inside out on substituting 1/c
for c
gives a double Mandelbrot set structure like the middle Riddle.
Mathematica:
Clear[g, z, k, nz]
k = 5
g[z_] = ExpandAll[((z + I)*(z - I))2/(z*(Sqrt[k - 1]*z/2 + Sqrt[5 -
k]/2)*(-Sqrt[k - 1]*z/2 + Sqrt[5 - k]/2))]
(*Mandelbrot with Sqrt[x2+y2] limited measure*)
(*by R. L. BAGULA 8 Nov 2009© *)
numberOfz2ToEscape[z_] := Block[
{escapeCount, nz = N[z],nzold=0},
For[
escapeCount = 0,
(Sqrt[Re[nz]2+Im[nz]2] < 32) && (escapeCount < 512) ,
nzold=nz;
nz=(1/z)*g[nz];
++escapeCount
];
escapeCount
]
FractalPureM[{{ReMin_, ReMax_, ReSteps_},
{ImMin_, ImMax_, ImSteps_}}] : Table[
numberOfz2ToEscape[x + y I],
{y, ImMin, ImMax, (ImMax - ImMin)/ImSteps},
{x, ReMin, ReMax, (ReMax - ReMin)/ReSteps}
]
arraym=FractalPureM[{{-14.001,14,300},{-14.001,14,300}}];
gr=ListPlot3D[arraym, Mesh -> False,AspectRatio -> Automatic,Boxed-
[quote]False, Axes->False,AmbientLightRGBColor[0,0.25,0.25]];
[/quote]
ListDensityPlot[arraym,
Mesh -> False,
AspectRatio -> Automatic,
ColorFunction->Hue,Axes->False,Frame->False]; |
|
|
| Back to top |
|
|
|
|
|
All times are GMT - 5 Hours
The time now is Mon Nov 30, 2009 8:00 pm
|
|