j_rn_mcm_msalem.jpg (JPEG Image, 995x995 pixels)

Discussion:

j_rn_mcm_msalem.jpg (JPEG Image, 995x995 pixels) - Scaled (87%)

(too old to reply)

Roger Bagula

2008-11-10 21:26:40 UTC

Loading Image...

Thia picture is a Julia like renormalization of a K3 ( Calabi -Yau
type of tetrahedral hyperbolic manifold
as a "field" and the minimal Salem string at that same polynomial degree):
Ratio / root in the sequence of the first is about 1.37 McMullen's Salem
and the second about 1,23.

g[x_] := x^2*(x^22 + x^21 - x^19 - 2*x^18 - 3*x^17 - 3*x^16 - 2*x^15 +
2*x^13 + 4*x^12 + 5*x^11 + 4*x^10 + 2*x^9 - 2*x^7 - 3*x^6 - 3*x^5 -
2*x^4 - x^3 + x + 1)/(1 - x^2 - x^3 +
x^7 + x^8 - x^10 - x^11 - x^12 + x^14 + x^15 - x^19 - x^20 + x^22)

It is another butterfly looking fractal.
I found the Salem link in OEIS from a reference in a number theory book
that came up in a search.
I appears none but the Lehmer Salem is in OEIS.
The lowest degree Salem in the table is an 8th degree x^8 that came up
in one of my census programs too.

2008-11-14 13:09:40 UTC

Permalink

Post by Roger Bagula
http://www.geocities.com/rlbagulatftn/j_rn_mcm_msalem.jpg
Thia picture is a Julia like renormalization of a K3 ( Calabi -Yau
type of tetrahedral hyperbolic manifold
Ratio / root in the sequence of the first is about 1.37 McMullen's Salem
and the second about 1,23.
g[x_] := x^2*(x^22 + x^21 - x^19 - 2*x^18 - 3*x^17 - 3*x^16 - 2*x^15 +
2*x^13 + 4*x^12 + 5*x^11 + 4*x^10 + 2*x^9 - 2*x^7 - 3*x^6 - 3*x^5 -
2*x^4 - x^3 + x + 1)/(1 - x^2 - x^3 +
x^7 + x^8 - x^10 - x^11 - x^12 + x^14 + x^15 - x^19 - x^20 + x^22)
It is another butterfly looking fractal.
I found the Salem link in OEIS from a reference in a number theory book
that came up in a search.
I appears none but the Lehmer Salem is in OEIS.
The lowest degree Salem in the table is an 8th degree x^8 that came up
in one of my census programs too.

Can you please elaborate more on your census programs?

Thanks !

Roger Bagula

2008-11-14 16:24:10 UTC

Permalink

Post by pg

Can you please elaborate more on your census programs?
Thanks !

The program has been posted to true number and active mathematica yahoo
egroups:

-------- Original Message --------
Subject: 14th dergree census gives one new low Salem
Date: Sun, 26 Oct 2008 14:09:16 -0800
From: Roger Bagula <***@sbcglobal.net>
Reply-To: ***@yahoo.com
To: true number theory <***@yahoogroups.com>,
***@yahoogroups.com, Seg Fan <***@yahoogroups.com>

Mathematica:
Table[Table[Table[Table[
Table[Table[
Table[Join[{{a, b, c, d,
e, f, g,
x0^14 + g*x0^13 + f*x0^12 + a*x0^11 + b*x0^10 + c*x0^9 +
d*x0^8 +
e*x0^7 + d*x0^6 +
c*x0^5 + b*x0^4 + a*x0^3 + f*x0^2 + g*x0 + 1}}, {Max[
Re[Table[x /. NSolve[x^14 + g*x^13 + f*x^12 + a*x^11 + b*x^10 + c*
x^9 + d*x^8 + e*x^7 + d*x^6 + c*x^5 + b*x^4 +
a*x^3 + f*
x^2 + g*x + 1 == 0, x][[n]], {n, 1, 14}]]], Max[
Abs[Table[x /. NSolve[x^14 + g*x^13 + f*x^12 + a*x^11 +
b*x^10 + c*x^9 +
d*x^8 + e*x^7 + d*x^6 + c*x^5 + b*x^4 + a*x^3 + f*
x^2 + g*x + 1 == 0, x][[n]], {n, 1,
14}]]]}], {a, -1, 1}], {
b, -1, 1}], {c, -1, 1}], {d, -1, 1}], {e, -1,
1}], {f, -1, 1}], {g, -1, 1}]
A lot of complex low absolute value root, but I only found this one
that was a low Salem. I didn't get to the end of the list...

%I A000001
%S A000001 1, 0, 1, 0, 1, 0, 1, 1, 1, 2, 1, 3, 2, 4, 3, 5, 5, 6, 8, 9,
12, 13, 17, 19,
24, 28, 34, 41, 49, 59, 71, 86, 103, 124, 149, 179, 215, 259, 311, 375,
450,
542, 651, 784, 942, 1133, 1363, 1638, 1971, 2369, 2851
%N A000001 Sequence from expansion of polynomial ( true Salem polynomial):
p(x)=1 - x^2 - x^7 - x^12 + x^14.
%C A000001 Low ratio of 1.20262.
Vector matrix Markov giving the same sequence is:
CompanionMatrix[p_, x_] := Module[{cl = CoefficientList[p, x], deg,
m}, cl = Drop[cl/Last[cl], -1]; deg = Length[cl];
If[deg == 1, {-cl}, m = RotateLeft[
IdentityMatrix[deg]]; m[[ -1]] = -cl; Transpose[m]]];
M = Transpose[CompanionMatrix[1 - x^2 - x^7 - x^12 + x^14, x]];
v[0] = Table[a[[n]], {n, 1, 14}];
v[n_] := v[n] = M.v[n - 1];
Table[v[n][[1]], {n, 0, 50}]
%F A000001 p(x)=1 - x^2 - x^7 - x^12 + x^14;
a(n) = coefficient_expansion(x^14*p(1/x)).
%t A000001 f[x_] = 1 - x^2 - x^7 - x^12 + x^14;
g[x] = ExpandAll[x^14*f[1/x]];
a = Table[SeriesCoefficient[Series[1/g[x], {x, 0, 50}], n], {n, 0, 50}];
%O A000001 1
%K A000001 ,nonn,
%A A000001 Roger L. Bagula and Gary W. Adamson (***@yahoo.com),
Oct 26 2008
RH
RA 192.20.225.32
RU
RI

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

2008-11-15 12:39:08 UTC

Permalink

Post by Roger Bagula

Post by pg

Can you please elaborate more on your census programs?
Thanks !

The program has been posted to true number and active mathematica yahoo
-------- Original Message --------
Subject: 14th dergree census gives one new low Salem
Date: Sun, 26 Oct 2008 14:09:16 -0800
Table[Table[Table[Table[
Table[Table[
Table[Join[{{a, b, c, d,
e, f, g,
x0^14 + g*x0^13 + f*x0^12 + a*x0^11 + b*x0^10 + c*x0^9 +
d*x0^8 +
e*x0^7 + d*x0^6 +
c*x0^5 + b*x0^4 + a*x0^3 + f*x0^2 + g*x0 + 1}}, {Max[
Re[Table[x /. NSolve[x^14 + g*x^13 + f*x^12 + a*x^11 + b*x^10 + c*
x^9 + d*x^8 + e*x^7 + d*x^6 + c*x^5 + b*x^4 +
a*x^3 + f*
x^2 + g*x + 1 == 0, x][[n]], {n, 1, 14}]]], Max[
Abs[Table[x /. NSolve[x^14 + g*x^13 + f*x^12 + a*x^11 +
b*x^10 + c*x^9 +
d*x^8 + e*x^7 + d*x^6 + c*x^5 + b*x^4 + a*x^3 + f*
x^2 + g*x + 1 == 0, x][[n]], {n, 1,
14}]]]}], {a, -1, 1}], {
b, -1, 1}], {c, -1, 1}], {d, -1, 1}], {e, -1,
1}], {f, -1, 1}], {g, -1, 1}]
A lot of complex low absolute value root, but I only found this one
that was a low Salem. I didn't get to the end of the list...
%I A000001
%S A000001 1, 0, 1, 0, 1, 0, 1, 1, 1, 2, 1, 3, 2, 4, 3, 5, 5, 6, 8, 9,
12, 13, 17, 19,
24, 28, 34, 41, 49, 59, 71, 86, 103, 124, 149, 179, 215, 259, 311, 375,
450,
542, 651, 784, 942, 1133, 1363, 1638, 1971, 2369, 2851
p(x)=1 - x^2 - x^7 - x^12 + x^14.
%C A000001 Low ratio of 1.20262.
CompanionMatrix[p_, x_] := Module[{cl = CoefficientList[p, x], deg,
m}, cl = Drop[cl/Last[cl], -1]; deg = Length[cl];
If[deg == 1, {-cl}, m = RotateLeft[
IdentityMatrix[deg]]; m[[ -1]] = -cl; Transpose[m]]];
M = Transpose[CompanionMatrix[1 - x^2 - x^7 - x^12 + x^14, x]];
v[0] = Table[a[[n]], {n, 1, 14}];
v[n_] := v[n] = M.v[n - 1];
Table[v[n][[1]], {n, 0, 50}]
%F A000001 p(x)=1 - x^2 - x^7 - x^12 + x^14;
a(n) = coefficient_expansion(x^14*p(1/x)).
%t A000001 f[x_] = 1 - x^2 - x^7 - x^12 + x^14;
g[x] = ExpandAll[x^14*f[1/x]];
a = Table[SeriesCoefficient[Series[1/g[x], {x, 0, 50}], n], {n, 0, 50}];
%O A000001 1
%K A000001 ,nonn,
Oct 26 2008
RH
RA 192.20.225.32
RU
RI
--
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html

Sorry, couldn't find it.

Mind post the url?

Thanks !

Roger Bagula

2008-11-15 16:47:08 UTC

Permalink

Post by pg
Sorry, couldn't find it.
Mind post the url?
Thanks !

The program was the Mathematica one liner in the previous post.

Roger Bagula

2008-11-15 17:15:29 UTC

Permalink

Clear[h, k, a, b, c, d, e, f, g, h, j, k, l, m, p, x];
h[x_] = a + b*x + c*x^2 + d*x^3 + e*x^4 + f*x^5 + g*x^6 + j*x^7 + x^8;
n0 = 8;
Union[Flatten[Table[If [Abs[x /. NSolve[h[x] == 0, x][[n0]]] -
Max[Abs[Table[
x /. NSolve[h[
x] == 0, x][[n]] , {n,
1, n0}]]] == 0 && Im[x /. NSolve[h[x] == 0, x][[n0]]] ==
0 && Sort[Abs[Table[x /.
NSolve[h[x] == 0, x][[n]] , {n, 1, n0}]]][[n0 - 1]] <=
1 &&
Sort[Abs[
Table[x /. NSolve[h[
x] == 0,
x][[n]] , {n, 1, n0}]]][[1]] > 0,
{Sort[Abs[Table[x /.
NSolve[h[x] == 0, x][[n]] , {n, 1, n0}]]], h[
x]}, {}], {a, -1,
1}, {b, -1, 1}, {c, -1, 1}, {d, -1, 1}, {e, -1, 1}, {f, -1,
1}, {g, -1, 1}, {j, -1, 1}], 7]]

Salem here is:
{{0.7808606944168847`, 0.9999999999999998`, 0.9999999999999998`,
0.9999999999999999`, 0.9999999999999999`, 1.`, 1.`,
1.2806381562677576`}, 1 - x^3 - x^4 - x^5 + x^8}

The degree 16 bi-Salem is:
-1+ 2 x^3 + 2 x^4 + 2 x^5 - x^6 - 2 x^7 - 5x^8 - 2 x^9 - x^10 + 2 x^11 +
2 x^12 + 2 x^13 - x^16
with absolute value roots:
{1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., 0.780861, 0.780861,
1.28064, 1.28064}
What recomends this polynomial is that it is the lowest of lowest degree
besides Lehmers at degree 10.
The next are the two 14th degrees I found with the oridinal cencus
program also on the low Salem list.

%I A147851
%S A147851 1,0,0,2,2,2,3,6,7,10,15,18,27,38,50,66,92,126,165,224,300,400,536,714,
%T A147851 948,1258,1676,2218,2932,3882,5128,6768,8924,11760,15479,20366,26780,
%U A147851 35174,46182,60602,79473,104158,136445,178654,233797,305834,399881
%N A147851 Coefficient expansion of : 1/(1 - x^3 - x^4 - x^5 + x^8)^2= 1/(-1+ 2 x^3 + 2 x^4 + 2 x^5 - x^6 - 2 x^7 - 5x^8 - 2 x^9 - x^10 + 2 x^11 + 2 x^12 + 2 x^13 - x^16)
%C A147851 Base Polynomial found using census program: ( also in the Salem list as #23): Clear[h, k, a, b, c, d, e, f, g, h, j, k, l, m, p, x]; h[x_] = a + b*x + c*x^2 + d*x^3 + e*x^4 + f*x^5 + g*x^6 + j*x^7 + x^8; n0 = 8; Union[Flatten[Table[If [Abs[x /. NSolve[h[x] == 0, x][[n0]]] - Max[Abs[Table[ x /. NSolve[h[x] == 0, x][[n]] , {n,1, n0}]]] == 0 && Im[x /. NSolve[h[x] == 0, x][[n0]]] ==0 && Sort[Abs[Table[x /.NSolve[h[x] == 0, x][[n]] , {n, 1, n0}]]][[n0 - 1]] <= 1 &&Sort[Abs[Table[x /. NSolve[h[x] == 0,x][[n]] , {n, 1, n0}]]][[1]] > 0, {Sort[Abs[Table[x /.NSolve[h[x] == 0, x][[n]] , {n, 1, n0}]]], h[x]}, {}], {a, -1,1}, {b, -1, 1}, {c, -1, 1}, {d, -1, 1}, {e, -1, 1}, {f, -1,1}, {g, -1, 1}, {j, -1, 1}], 7]]
%D A147851 http://www.cecm.sfu.ca/~mjm/Lehmer/lists/SalemList.html
%F A147851 Coefficient expansion of : 1/(1 - x^3 - x^4 - x^5 + x^8)^2= 1/(-1+ 2 x^3 + 2 x^4 + 2 x^5 - x^6 - 2 x^7 - 5x^8 - 2 x^9 - x^10 + 2 x^11 + 2 x^12 + 2 x^13 - x^16)
%t A147851 f[x_] = 1 - x^3 - x^4 - x^5 + x^8; g[x] = ExpandAll[f[x]*x^8*f[1/x]]; a = Table[SeriesCoefficient[Series[1/g[x], {x, 0, 50}], n], {n, 0, 50}]
%K A147851 nonn
%O A147851 0r,4
%A A147851 Roger L. Bagula (rlbagulatftn(AT)yahoo.com), Nov 15 2008

Roger Bagula

2008-11-14 16:29:58 UTC

Permalink

-------- Original Message --------
Subject: simplex_eq_vw1.jpg (JPEG Image, 637x498 pixels)
Date: Wed, 12 Nov 2008 12:01:25 -0800
From: Roger Bagula <***@sbcglobal.net>
Reply-To: ***@yahoo.com
To: true number theory <***@yahoogroups.com>,
***@yahoogroups.com, chaos theory
<***@yahoogroups.com>, ***@yahoogroups.com,
fractals <***@groups.msn.com>, ***@yahoogroups.com,
aaafractalchaos <***@yahoogroups.com>, ***@yahoogroups.com

Pictures of the more symmetrical equalaterial simplex surface:
Loading Image...

Loading Image...

{x, y, z} = { (-Sqrt[3] + Sqrt[3] Cos[p] - 3 Sin[p]) (-Sqrt[3] + Sqrt[3]
Cos[t] - 3 Sin[t])/3,
(-Sqrt[3] + Sqrt[3] Cos[p] + 3 Sin[ p]) (-Sqrt[3] +
Sqrt[3] Cos[t] + 3 Sin[t])/3,
(1 + 2 Cos[p]) (1 + 2 Cos[t])}/3

Mathematica:
Clear[g, gr, x, y, z]
{x, y, z} = { (-Sqrt[3] + Sqrt[3]
Cos[p] - 3 Sin[
p]) (-Sqrt[3] + Sqrt[3] Cos[t] - 3 Sin[t])/3, (-Sqrt[3] +
Sqrt[3] Cos[p] + 3 Sin[p]) (-Sqrt[3] + Sqrt[
3] Cos[t] + 3 Sin[t])/3, (1 + 2 Cos[p]) (1 + 2 Cos[t])}/3
g = ParametricPlot3D[{x, y, z},
{t, -Pi, Pi}, {p, -Pi, Pi},
ViewPoint -> {2.8, -1.9, 0.1},
PlotPoints -> {60, 60},
Boxed -> False,
Axes -> False,
RenderAll -> False,
LightSources ->
{{{0.7071, 0, 0.7071}, RGBColor[0.9481, 0, 0]},
{{0.5773, 0.5773, 0.5773}, RGBColor[0, 0.8888, 0]},
{{0, 0.7071, 0.7071}, RGBColor[0, 0, 1]}}
]
selectgraphics3d[graphics3dobj_, bound_, opts___] :=
Show[Graphics3D[Select[graphics3dobj,
(Abs[#[[1, 1, 1]]] < bound && Abs[#[[1, 1, 2]]] < bound &&
Abs[#[[1, 1, 3]]] < bound && Abs[#[[1, 2, 1]]] < bound &&
Abs[#[[1, 2, 2]]] < bound && Abs[#[[1, 2, 3]]] < bound &&
Abs[#[[1, 3, 1]]] < bound && Abs[#[[1, 3, 2]]] < bound &&
Abs[#[[1, 3, 3]]] <
bound && Abs[#[[1, 4, 1]]] < bound &&
Abs[#[[1,
4, 2]]] < bound && Abs[#[[1, 4, 2]]] < bound
) &]], opts]
dip[ins_][g_] := $DisplayFunction[Insert[g, ins, {1, 1}]]
gr = selectgraphics3d[g[[1]], 8,
Boxed -> False, ViewPoint -> {2.9, -1.4, 1.2},
DisplayFunction -> dip[EdgeForm[]], PlotRange -> All];

gr2 = selectgraphics3d[g[[1]], 8, Boxed ->
False, ViewPoint -> {-1.938, -1.657, 2.225}, DisplayFunction ->
dip[EdgeForm[]], PlotRange -> All];
selectgraphics3d[g[[1]], 8, Boxed -> False, ViewPoint -> {3.378, -0.038,
0.194}, DisplayFunction -> dip[EdgeForm[]], PlotRange -> All]
selectgraphics3d[g[[1]], 8,
Boxed -> False, ViewPoint -> {0.298, 0.003, -3.371},
DisplayFunction -> dip[EdgeForm[]], PlotRange -> All]
--
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html
alternative email: ***@sbcglobal.net

-------- Original Message --------
Subject: Re: simplex_square.jpg (JPEG Image, 1672x804 pixels) - Scaled (67%)
Date: Fri, 14 Nov 2008 08:15:48 -0800

Loading Image...

{0,0},{Sqrt[2],0},{0,Sqrt[2]}}
Four of these triangles make a square
and are one of the basic geometries.
{{1, 0, 0},
{1, Sqrt[2], 0},
{1, 0,Sqrt[2]}
Replace each row vector
with {1,x,y} to get the corrdinate matrix
x0=1/2-x/Sqrt[2]-y/Sqrt[2]
y0=x/Sqrt[2]
z0=y/Sqrt[2]
Replacing {x,y} by{Sin[t],Cos[t]} and{Sin[p],Cos[p]}.
{x0(t)*x0(p), y0(t)*y0(p), z0(t)*z0(p)}
(x,y,z}={(1/4)*(-2 +Sqrt[2]*Cos[p] + Sqrt[2]*Sin[p])(-2 + Sqrt[2]*Cos[
t] +Sqrt[2]*Sin[t]), Cos[p] Cos[t]/2, Sin[p]Sin[t]/2}

The inspiration of the square simplex was the realization that the
equalaterial scale for tiling the plane was 1+Sqrt[3]
which is so close to a similarity dimension of one so that it doesn't
make a real difference.
So I realized that a triangle that fit into a ratio two tiling of the
plane was necessary for
a Sierpinski type fractal to appear.
This symmetry shows up in the quantum Pascal triangle sequences
as well. It is kind of nice when you find a geometry that
has application across the spectrum of Mathematics.

Loading Image...

Clear[x, y, a, b, z, w, f, fa, ga, ha, f1, f2, f3, r]
(*based on Wellin's old IFS program type*)
f1[{x_, y_}] := {1/Sqrt[8] - x/2 - y/2, x/2}
f2[{x_, y_}] := {x/2 , y/2}
f3[{x_, y_}] := {x/2, 1/Sqrt[8] - x/2 - y/2}
f[x_] := Which[(r = Random[]) ≤ 1/3, f1[x], r ≤ 2/3, f2[x], r ≤ 1.00, f3[x]]
ifs[n_] := Show[Graphics[{PointSize[.001], Map[Point, NestList[f, {
0.000001, 0}, n]]}], AspectRatio -> Automatic, PlotRange -> All]
ifs[50000]

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

Roger Bagula

2008-11-15 16:44:31 UTC

Permalink

Loading Image...

Adding a dimension to your triangle
m[0] = {{1, 1, 0},
{1, 0, 1},
{1, I, 0}}
m[1] = {{1,x, y},
{1, 0, 1},
{1, I, 0}}
m[2] = {{1, 1, 0},
{1, x, y},
{1, I, 0}}
m[3] = {{1, 1, 0},
{1, 0, 1},
{1, x, y}}

Det[m[0]]=1-I
The coordinates become:
a = ComplexExpand[Table[Det[m[i]]/Det[m[0]], {i, 1, 3}]]
Real:
{1/2+x/2-y/2,y,1/2-x/2-y/2}
a circle as :
ParametricPlot3D[Re[a] //. x -> Cos[t] /. y -> Sin[t], {t, -Pi, Pi}]
Imaginary:
{-1/2+x+y/2,0,1/2-x/2-y/2}
a line as:
ParametricPlot3D[Im[a] //. x -> Cos[t] /. y ->
Sin[t], {t, -Pi, Pi}, ViewPoint -> {-0.129, 3.380, -0.076}]

As an IFS you get a strange set of self-similar triangles due to the
x=y, y=0 which gives the edge lines:
Clear[x, y, a, b, z, w, f, fa, ga, ha, f1, f2, f3, r]
(*Wellin IFS program type*)
f1[{x_, y_}] := {1/2 + x/2 - y/2, 1/2-x/2-y/2}
f2[{x_, y_}] := {y, 0}
f3[{x_, y_}] := {1/2 - x/2 - y/2, 1/2 - x/2 - y/2}
f[x_] := Which[(r = Random[]) ≤ 1/3, f1[x], r ≤ 2/3, f2[x], r ≤ 1.00, f3[x]]
ifs[n_] :=
Show[Graphics[{PointSize[.001], Map[Point, NestList[f, {0.000001,
0}, n]]}], AspectRatio -> Automatic, PlotRange -> All]
ifs[50000]
Removing the middle transform gives a sig-sag triangle wave that decreases.
Respectfully, Roger L. Bagula
11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814
:http://www.geocities.com/rlbagulatftn/Index.html
alternative email: ***@sbcglobal.net

Roger Bagula

2008-11-15 19:19:17 UTC

Permalink

Box counting dimension of the complex simplex IFS using Paul Bourke's FDC:
Raw={1, 0, 1703, 7.44015`, 2, -0.693147`, 1567, 7.35692`, 4, -1.38629`,
841,
6.73459`, 24, -3.17805`, 169, 5.1299`, 45, -3.80666`, 88, 4.47734`, 68,
-4.21951`, 47, 3.85015`, 91, -4.51086`, 35, 3.55535`, 113, -4.72739`, 31,
3.43399`, 136, -4.91265`, 25, 3.21888`, 159, -5.0689`, 15, 2.70805`, 182,
-5.20401`, 18, 2.89037`, 364, -5.89715`, 10, 2.30259`}
b = Table[{raw[[n + 1]], raw[[n + 3]]}, {n, 1, Length[raw], 4}]
g = ListPlot[b]
f[x_] = Fit[b, {1, x}, x]
g1 = Plot[f[x], {x, -7, 1}]
Show[{g, g1}]

The line is: ( very close to one dimensional)
y=7.85803 + 0.94481 x

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

Roger Bagula

2008-11-20 18:29:13 UTC

Permalink

Loading Image...

This idea of using the triangle of points formed \by the three roots of
the Minimal Pisot
polynomial occured to me as did the idea of a rational approximation of
the Minimal Pisot as a
Simplex matrix.
M={{1, 4/3. 0},
{1,-2/3,1/2},
{1,-2/3,-1/2}}
which isn't at all a very good approximation:
(x-4/3)(x+2/3+I/2)*(x+2/3-I/2)=x3-13*x/12-25/27
6 times that gives all integers:
{{6, 8, 0},
{6, -4, 3},
{6, -4, -3}}

Here is how I got the IFS:
Getting the cordinates from the polynomial x3-x-1=0:
Clear[m, t, a, ap, p]
(* simplex matrices/ coordinates*)
x0 = x /. NSolve[x3 - x - 1 == 0, x][[3]]
y0 = 0
x1 = Re[x] /. NSolve[x3 - x - 1 == 0, x][[2]]
y1 = Im[x] /. NSolve[x3 - x - 1 == 0, x][[2]]
x2 = Re[x] /. NSolve[x3 - x - 1 == 0, x][[1]]
y2 = Im[x] /. NSolve[x3 - x - 1 == 0, x][[1]]
m[0] = {{1, x0, y0}, {1, x1, y1},
{1, x2, y2}}
m[1] = {{1, x, y}, {1, x1, y1},
{1, x2, y2}}
m[2] = {{1, x0, y0}, {1, x, y},
{1, x2, y2}}
m[3] = {{1, x0, y0}, {1, x1, y1},
{1, x, y}}
A = Det[m[0]]/2
N[A]
a = Table[Det[m[i]]/Det[m[0]], {i, 1, 3}]

Plotting the IFS with beta= 1.324717957244746 used as ratio:
Clear[x, y, a, b, z, w, f, fa, ga, ha, f1, f2, f3, r]
(*Wellin IFS program type*)
r0 = 1.324717957244746;
f1[{x_, y_}] := {0.4475103277834122` (0.7448617666197445`\[InvisibleSpace] +
1.1245590241246028` x), 0.4475103277834122` (
0.7448617666197445`\[InvisibleSpace] - 0.5622795120623014` x +
1.987076935867119` y)}/r0
f2[{x_, y_}] := {0.4475103277834122` (0.7448617666197445`\[InvisibleSpace] -
0.5622795120623014`
x + 1.987076935867119` y), 0.4475103277834122` (0.7448617666197445`
\[InvisibleSpace] - 0.5622795120623014` x - 1.987076935867119` y)}/r0
f3[{x_, y_}] := {0.4475103277834122` (0.7448617666197445`\[InvisibleSpace] -
0.5622795120623014`
x - 1.987076935867119` y), 0.4475103277834122` (0.7448617666197445`
\[InvisibleSpace] + 1.1245590241246028` x)}/r0
f[x_] := Which[(r = Random[]) ≤ 1/3, f1[x], r ≤ 2/3, f2[x], r ≤ 1.00, f3[x]]
ifs[n_] := Show[Graphics[{PointSize[.001],
Map[Point, NestList[f, {0.000001, 0}, n]]}], AspectRatio -> Automatic,
PlotRange -> All]
ifs[250000]