Post has attachment
Getting E_8 from the dodecahedron using a small beta root : alpha

Yesterday I ran the Moran program on the dodecahedron invariant polynomial.
That process gave 240 solutions: and the smallest real trace gave a ver nice space-filling-sphere-filling set.
Thinking in terms of the dodecahedron exceptional group at 248 elements I added a
small beta root to make the 252 resulting roots to be an hyperbolic H_4 manifold times the guts E_8:
H_4*E_8 type of solution.
I then looked for the smallest real root trace vector and ran that as a kleinian group.
The result appears to be quantified in stripes.
The 21 roots as being SO(7) orthogonal seem to make sense as a B_3 orthogonal
with the alpha root being the time-gravity quantization, place the origin of the fine structure constant
in gravitational interactions with electromagnetic -weal fields.
(Mathematica)
Clear[m1, m2, a, b, c, d, e, f, g, h]
(* Moran matrices*)
m1 = {{a, -b}, {b, a}};
z1 = a + I*b;
ComplexExpand[z1^2];
m2 = {{c, -d}, {d, c}};
(* SL(2,c) Mobius transform*)
m3 = {{a, b}, {c, d}};
m4 = m1.m2;
(* quaternion*)
e1 = Det[m1] + Det[m2] - 1;
(* SL(2,C))
e2 = Det[m3] - 1;
( Markov Kleinian group*)

e3 = Tr[m1]^2 + Tr[m2]^2 + Tr[m4]^2 - Tr[m1]Tr[m2]*Tr[m4];
( irreduciable polynomial*)

e4 = (-1 - 228 a^5 - 495 a^10 + 228 a^15 - a^20)(a - 1/137.03608)
( solving for the group matrices*)
mm = {m1, m2} /.
NSolve[{e1 == 0, e2 == 0, e3 == 0, e4 == 0}, {a, b, c, d}]
Length[mm]

(* traces*)
mmtr =
N[{Tr[m1], Tr[m2]}] /.
NSolve[{e1 == 0, e2 == 0, e3 == 0, e4 == 0}, {a, b, c, d}]
ListPlot[Abs[mmtr], PlotStyle -> Red]

(* find minimum traces*)
min =
Min[Abs[{Tr[m1], Tr[m2]}.{Tr[m1], Tr[m2]}] /.
NSolve[{e1 == 0, e2 == 0, e3 == 0, e4 == 0}, {a, b, c, d}]]

Table[If[Abs[mmtr[[i]].mmtr[[i]]] - min < 10^-14, mmtr[[i]], {}], {i,
Length[mmtr]}]
(end)
Union[
Table[If[
Abs[mmtr[[i, 1]]] - 0.014594696520799486 <
10^(-14), {Abs[mmtr[[i]].mmtr[[i]]], mmtr[[i]]}, {}], {i, Length[mmtr]}]]
(end)
(* mathematica*)
Clear[cr, cols, cr2, cr3, cr4]
allColors = ColorData["Legacy"][[3, 1]];
firstCols = {"LightBlue", "Blue", "Cyan", "White", "Yellow", "LightYellow",
"White", "DeepNaplesYellow", "Tomato", "Pink", "LightPink", "White",
"Purple", "DarkOrchid", "Magenta", "DodgerBlue", "GoldOchre", "LightPink",
"Magenta", "Green", "DarkOrchid", "LightSalmon", "LightPink", "Sienna",
"Green", "Mint", "DarkSlateGray", "ManganeseBlue", "SlateGray",
"DarkOrange", "MistyRose", "DeepNaplesYellow", "GoldOchre", "SapGreen",
"Yellow", "Yellow", "Tomato", "DeepNaplesYellow", "DodgerBlue", "Cyan",
"Red", "Blue", "DeepNaplesYellow", "Green", "Magenta", "DarkOrchid",
"LightSalmon", "LightPink", "Sienna", "Green", "Mint", "DarkSlateGray",
"ManganeseBlue", "SlateGray", "DarkOrange", "MistyRose",
"DeepNaplesYellow", "GoldOchre", "SapGreen", "Yellow", "LimeGreen"};
cols = ColorData["Legacy", #] & /@
Join[firstCols, Complement[allColors, firstCols]];
rotate[theta_] := {{Cos[theta], -Sin[theta]}, {Sin[theta], Cos[theta]}};
cr[n_] := cr[n] = cols[[n]];
cr2[n_] := cr2[n] = cols[[n + 4]];
cr3[n_] := cr3[n] = cols[[n + 8]];
cr4[n_] := cr4[n] = cols[[n + 12]];
Clear[w, ww, n, m, a0, r, r, x, s, c]

ta = 0.014594696520799486`; tb = -1.4090440400698894` -
1.409063212991764` I; tab =
0.5 (ta tb - Sqrt[ta^2 tb^2 - 4 (ta^2 + tb^2)]); z0 = (tab -
2) tb/(tb tab - 2 ta + 2 I tab);
a = {{ta/2, (ta tab - 2 tb + 4 I)/(2 tab + 4)/
z0}, {(ta tab - 2 tb - 4 I) z0/(2 tab - 4), ta/2}}; A = Inverse[a]; b =
0.5 {{tb - 2 I, tb}, {tb, tb + 2 I}}; B = Inverse[b];
Affine[{z1_, z2_}] := 0.001 Round[(z1/z2)/0.001];
Children[{z_, n_}] := {Affine[{a, b, A, B}[[#]].{z, 1}], #} & /@
Delete[Range[4], {3, 4, 1, 2}[[n]]];
aa1 = {Re[#[[1]]], Im[#[[1]]]} & /@
Nest[Union[Flatten[Children /@ #, 1]] &,
Table[{Affine[{a, b, A, B}[[i]].{0, 1}], i}, {i, 1, 4}], 10];
Length[aa1]
aa = Delete[Union[aa1], Length[Union[aa1]]];

gg = ListPlot[aa, AspectRatio -> Automatic,
PlotStyle -> {Black, PointSize[0.001]}, ImageSize -> 1500,
PlotRange -> {{-5, 5}, {-5, 5}}*(2/5), Axes -> False]
dlst = Table[1 + Mod[n, 4], {n, Length[aa]}];
ptlst = Point[Developer`ToPackedArray[aa],
VertexColors -> Developer`ToPackedArray[cr2 /@ dlst]];
g2 = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic,
ImageSize -> 1500, Background -> Black,
PlotRange -> {{-5, 5}, {-5, 5}}*(2/5)];

bb = Table[{2*aa[[i, 1]], 2*aa[[i, 2]],
1 - aa[[i]].aa[[i]]}/(1 + aa[[i]].aa[[i]]), {i, Length[aa]}];
ptlsb = Point[Developer`ToPackedArray[bb],
VertexColors -> Developer`ToPackedArray[cr3 /@ dlst]];
cc = Table[{2*aa[[i, 1]],
2*aa[[i, 2]], -(1 - aa[[i]].aa[[i]])}/(1 + aa[[i]].aa[[i]]), {i,
Length[aa]}];
ptlsc = Point[Developer`ToPackedArray[cc],
VertexColors -> Developer`ToPackedArray[cr2 /@ dlst]];
g22a = Graphics3D[{PointSize[.001], ptlsb, ptlsc}, AspectRatio -> Automatic,
PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}, {-1.01, 1.01}},
ImageSize -> 1500, Background -> Black, ViewPoint -> {-5, 5, 2},
Boxed -> False];
(end)

(* end*)
(* mathematica*)
(Geerlings,Jacob Kaller (2009)
Honors Thesis (53 pages)
Committee Chair/Thesis Adviser:Borthwick,David
Committee Members:Hamilton,Emily;Berland,Keith;
Research Fields:Mathematics
Keywords:Limit sets;Kleinian groups;Moebius transformations;Mobius \
transformations;Parabolic;commutator;algorithm;torsion-free;conjugation
Program:College Honors Program,Mathematics
Permanent url:http://pid.emory.edu/ark:/25593/1b7z9*)
(*Directions:
Run the first cell after this one. It has all the functions.
Then, run the next cell, putting in desired tra, trb for the arguments of \
initialize[].
After it spits it out, that cell can repeatedly be run with various \
parameters without rerunning the first cell.)
levmax = 300;
epsilon = .1;
fixpt[mtrx_] := (mtrx[[1, 1]] - mtrx[[2, 2]] +
Sqrt[((mtrx[[1, 1]] + mtrx[[2, 2]])^2 - 4 )])/(2*mtrx[[2, 1]]);
mobOnPt[mtrx_,
z_] := (mtrx[[1, 1]] z + mtrx[[1, 2]])/(mtrx[[2, 1]] z + mtrx[[2, 2]]);
getXY[z_] := {Re[z], Im[z]};
initialize[a_, b_, A_, B_] :=
{

gens = {a, b, A, B};
fix = Map[fixpt, gens];
word = Table[0*n, {n, 5000}];
tags = Table[0*n, {n, 5000}];
tags[[1]] = 1; lev = 1;
word[[1]] = gens[[1]];
newpt = 0;
oldpt = 23;
counter = 1;
btflag = False;
atflag = False;
}
branchTermination[] :=
{
newpt = mobOnPt[word[[lev]], fix[[tags[[lev]]]]];
If[Abs[newpt - oldpt] < epsilon ⇒ lev >= levmax,
Sow[{oldpt, newpt}];
oldpt = newpt;
counter++;
If[lev > levmax, Print[LOOKOUT!!]];
btflag = True, btflag = False];
}
goForward[] :=
{
lev = lev + 1;
tags[[lev]] = Mod[tags[[lev - 1]] + 1, 4, 1];
word[[lev]] = word[[lev - 1]].gens[[tags[[lev]]]];
}
goBackward[] := {lev -= 1; btflag = False;}
availableTurn[] :=
If[Mod[tags[[lev + 1]] + 1, 4, 1] == tags[[lev]], atflag = False,
atflag = True]
turnAndGoForward[] :=
{
tags[[lev + 1]] = Mod[tags[[lev + 1]] - 1, 4, 1];
If[lev == 0, word[[1]] = gens[[tags[[1]]]],
word[[lev + 1]] = word[[lev]].gens[[tags[[lev + 1]]]]];
lev = lev + 1;
}
Clear[s, m, a, b, A, B, mu]
ta = 0.014594696520799486`; tb = -1.4090440400698894` -
1.409063212991764` I; tab =
0.5 (ta tb - Sqrt[ta^2 tb^2 - 4 (ta^2 + tb^2)]); z0 = (tab -
2) tb/(tb tab - 2 ta + 2 I tab);
a = {{ta/2, (ta tab - 2 tb + 4 I)/(2 tab + 4)/
z0}, {(ta tab - 2 tb - 4 I) z0/(2 tab - 4), ta/2}}; A = Inverse[a]; b =
0.5 {{tb - 2 I, tb}, {tb, tb + 2 I}}; B = Inverse[b];
levmax = 200;
epsilon = .01;
countermax = 500000;
initialize[a, b, A, B];
segs = Reap[
While[((lev != 0 ⇒ tags[[1]] == 1) ⇓ counter < countermax),
branchTermination[];
While[! btflag, branchTermination[]; If [! btflag, goForward[]]];
goBackward[];
availableTurn[];
While[lev != 0 ⇓ ! atflag, availableTurn[]; If[! atflag, goBackward[]]];
If[tags[[1]] == 1 ⇒ lev != 0, turnAndGoForward[]]];];
Print["algorithm finished. making ptlist"];
ptlista =
Reap[Do[Sow[getXY[segs[[2, 1, i, 1]]]], {i, 2, Length[segs[[2, 1]]]}]][[2,
1]];

Length[ptlista]
ptlist = Delete[Union[ptlista], Length[Union[ptlista]]];
ptlist2 = Table[-ptlist[[i]] + {0, 0}, {i, Length[ptlist]}];
hh = Show[
Graphics[{(Orange,Line[ptlist]), Red, Point[ptlist],
PointSize[0.0005]}],
Graphics[{(Cyan,Line[ptlist2]), Blue, Point[ptlist2],
PointSize[0.0005]}], PlotRange -> {{-5, 5}, {-5, 5}}*(2/5),
Axes -> False, AspectRatio -> 1, ImageSize -> 1500];
g3 = Show[{gg, hh}];
Export["Dodecahedron_H4_E8polynomialsmallestrealtraces.jpg", {g2, g22a, g3}]
(* end*)
Photo

Post has attachment
Again the Dodecahedron , but instead of the overal minimum , this is the real only minimum: again the Geerlings Limit set is very space filling: ta = -0.20905775462216336` - 0.6434136097194781` I; tb =
1.495422808276145` + 0.10753459504180088` I;
Photo

Post has attachment
Using the dodecahedron invariant polynomial in the Moran program gives this minimal traces vector Kleinian group out of 240 solutions ( the Geerling Limit set shows very good space filling : ( one of the best yet);
{ta,tb}={1.33786 - 0.972011 I, 1.34414 + 1.10022 I}
Photo

Post has attachment
An update of my doubled Silver dragon substitution ( came up searching for Silver this morning):s[1] = {2, 1, 1, 2}; s[2] = {3}; s[3] = {4, 3, 3, 4}; s[4] = {1};
Originally based on the Deking classic substitution by doubling the middle in two of the substitutions:
F.M.Dekking, "Recurrent Sets", Advances in Mathematics, vol .44, no 1, April 1982, page 96, section 4.11
Photo

Post has attachment
Showing the Cubic Silver tiling with selfsimilar overlap:
Photo

Post has attachment
a Silver cubic ( near tiling)
The Idea here is to get an Silver mean type of tiling with two transforms using a
cubic polynomial : x^3-2*x-1
I used Dieter Steemann’s code and adapted it to output experimentally.
(Mathematica code)
Clear[theta, a1, α, cr, x, y];
Off[Solve::"ifun"]
a1 = Solve[a^3 - 2*a^2 - 1 == 0, a] // N
c0 = Sqrt[a] /. a1[[3]] // N
α = ArcCos[Re[a]/c0] /. a1[[3]] // N
theta = Pi + N[α] /. a1[[3]]
z = c0 Cos[theta] + I c0 Sin[theta]
{c, s} = {Re[z], Im[z]}
{c1, s1} = {-Re[z^2], -Im[z^2]}
{c2, s2} = {-Re[z^3], Im[z^3]}*(2)
{p1, p2} = {Det[{{-c, s}, {-s, -c}}], Det[{{c1, -s1}, {s1, c1}}]}
it = 2000000;
crn = List @@@ (ColorData["Legacy", #] & /@ {"Red", "Yellow", "Orange",
"Tomato"});
{p1, p2} = {Det[{{c1, -s1}, {s1, c1}}], Det[{{c2, -s2}, {s2, c2}}]};
dlst = Table[
Which[(r = RandomReal[]) <= p1, 1, r <= p1 + p2, 2, True, 2], {it}];
f[1, {x_, y_}] := {{c1, -s1}, {s1, c1}}.{x, y} + {c1, s1};
f[2, {x_, y_}] := {{c2, -s2}, {s2, c2}}.{x, y} + {c2, s2};
pt = {0.5, 0.5};
cr[n_] := cr[n] = crn[[n]];
ptlst = Point[
Developer`ToPackedArray[Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
g = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic,
PlotRange -> All, ImageSize -> 1000, Background -> Black]
(end)
Photo

Post has attachment
a second Silver cubic near tile
(Mathematica program)Clear[f, dlst, pt, cr, ptlst, M, r, p, rotate]
allColors = ColorData["Legacy"][[3, 1]];
firstCols = {"Red", "Yellow", "Orange", "DeepNaplesYellow",
"LightYellow", "Banana", "DarkOrange", "White", "ManganeseBlue",
"Blue", "Magenta", "Green", "DarkOrchid", "LightSalmon",
"LightPink", "Sienna", "Green", "Mint", "DarkSlateGray",
"ManganeseBlue", "SlateGray", "DarkOrange", "MistyRose",
"DeepNaplesYellow", "GoldOchre", "SapGreen", "Yellow"};
cols = ColorData["Legacy", #] & /@
Join[firstCols, Complement[allColors, firstCols]];
Length[cols];
(IFS by Roger L.Bagula 22Sept 2018©)

Clear[z, x, c, s, c1, s1, f, g]

z = (x /. NSolve[x^3 - 2*x^2 - 1 == 0, x][[1]])
c = Re[z^5]5.281371874977826`
s = Im[z^5]*5.281371874977826`
c1 = N[Re[z]]
s1 = N[Im[z]]
{p1, p2} = {Det[{{c, s}, {s, c}}], Det[{{c2, -s2}, {s2, c2}}]}
p1 + p2 - 1
Clear[x5, y5, y3, y3]
x5 = c1;
y5 = s1;
x3 = c;
y3 = s;

( Riddle Transform definition*)
Clear[f, f1, f2, aa, bb, cc, ss, x1, \
y1]
aa = (x*x5 - y*y5);
bb = (x*y5 + y*x5);
cc = Cos[t*Pi];
ss = Sin[t*Pi];
x1 = aa*cc - bb*ss + x5 + (x5)t
y1 = aa*ss + bb*cc + y5 - (x5)*t
-0.10278471520029515` - 0.10278471520029515` x +
0.6654569511528134` y
-0.6654569511528134` - 0.6654569511528134` x - 0.10278471520029515` y
t = 0;
( IFS program type*)
(* as in the 15: tile type*)

f[1, {x_, y_}] = {x*x3 - y*y3 + x3, x3*y + y3*x + y3}
f[2, {x_, y_}] = {x1, y1}
pt = {0.5, 0.5};


dlst = Table[ Which[(r = Random[]) <= p1, 1, r <= 1, 2]
, {n, 3000000}];
cr[n_] := cr[n] = cols[[n ]];
aa = Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}];
ListPlot[aa, PlotStyle -> {{Red, Blue}, PointSize[0.001]},
ImageSize -> 1000];
ptlst = Point[Developer`ToPackedArray[aa],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
g2a = Graphics[{PointSize[.001], ptlst},
AspectRatio -> Automatic,(PlotRange\[Rule]{{-0.11,1.11},{-0.41,
0.81}},)ImageSize -> 1000, Background -> Black];
Export["Silivercubic15.jpg", g2a]
(bb=Table[{2*aa[[i,1]],2*aa[[i,2]],1-aa[[i]].aa[[i]]}/(1+aa[[i]].aa[[\
i]]),{i,Length[aa]}];
ptlsb=Point[Developer`ToPackedArray[bb],VertexColors\[Rule]Developer`\
ToPackedArray[cr/@dlst]];
cc=Table[{2*aa[[i,1]],2*aa[[i,2]],(1-aa[[i]].aa[[i]])}/(1+aa[[i]].aa[\
[i]]),{i,Length[aa]}];
ptlsc=Point[Developer`ToPackedArray[cc],VertexColors\[Rule]Developer`\
ToPackedArray[cr/@dlst]];
g22a=Graphics3D[{PointSize[.001],ptlsb,ptlsc},AspectRatio\[Rule]\
Automatic,PlotRange\[Rule]{{-1.01,1.01},{-1.01,1.01},{-1.01,1.01}},\
ImageSize\[Rule]{1000,1000},Background\[Rule]Black,ViewPoint\[Rule]{-\
5,5,2},Boxed\[Rule]False])
(end)
Photo

Post has attachment
Here is a zoom from a frame in the following animation of mine:

https://youtu.be/goaNAkoS97c

Looks pretty damn dynamic. ;^)

https://plus.google.com/101799841244447089430/posts/JeJpbC2R3QA

_
#Fractal #Math #Mandelbrot #Art #Space
Photo

Post has attachment
A twin dragon Cesaro effect:
Animated Photo

Post has attachment
The Moran matrix Fuchsian triangle groups
( this code and text without the Google+ strike throughs is posted at the yahoo groups)
After yesterday’s successful failure with rational polynomial
I’ve gone back to the drawing board. I found a theorem in
Tilings and Pattern, an Introduction by Grünbaum and Shephard page 194
https://www.amazon.com/Tilings-Patterns-Introduction-mathematical-sciences/dp/0716719983/ref=sr_1_fkmr0_1?ie=UTF8&qid=1516547311&sr=8-1-fkmr0&keywords=Tilings+and+Pattern%2Can+Introduction+by+Gr%C3%BCnbaum+and+Shephard+page+194
that is actually a form of the Fuchsian triangle group; <2,j,k>.
As a result I derived a three Matrix Moran polynomial theory based on Fuchsian group
and powers of the first integer of <n,m,l> ;n.
The two polynomials: for <2,3,5> and <2,3,7> are probably new ( I’ve never seen them before)
p[x_]=x^(Log[5]/Log[2]) + x^(Log[3]/Log[2]) + x - 1 - 1/30
p[x_]= x^(Log[7]/Log[2]) + x^(Log[3]/Log[2]) + x - 1 + 1/42
The first is an elliptic polynomial and the second is hyperbolic.
This new Moran matrix theory allows for Riemannian non-Eulcidean tilings polynomials
expanded on powers of 1/2.
The power are interesting as they are Sierpinski type Moran dimensional powers:
(Cantor,Log[2]/Log[3]),Log[3]/Log[2],Log[5]/Log[2],Log[7]/Log[2][,…
If instead of expanding on the ratio 1/2, you choose 1/3, you get a different set of power solutions
and an expansion on 1/3 for the polynomials.
For example if you choose an irrational base of Exp[1],E:
you get an polynomial x^a+c^b+x^c-1==0;
(Second case:<2,3,6> or <2,6,3> Hexagons tiling)

Solve[(1/E)^a == 1/6, a] /. C[1] -> 0
Solve[(1/E)^b == 1/3, b] /. C[1] -> 0
Solve[(1/E)^c == 1/2, c] /. C[1] -> 0
Out[78]= {{a -> Log[6]}}
Out[79]= {{b -> Log[3]}}
Out[80]= {{c -> Log[2]}}
(* x^(Log[6])+x^(Log[3])+x^(Log[2])-1 polynomial*)
x /.
FindRoot[
x^a + x^b + x^c - 1 == 0 /. a -> Log[6] /. b -> Log[3] /. c -> Log[2], {x,
1.99}]
0.367879
% - 1/E
0.
Generally for <a,b,c> for an exponential base polynomial:
p[x_,a_,b_,c_]= x^(Log[a])+x^(Log[b])+x^(Log[c])-1(1/a+1/b+1/c-1)
Choosing the polynomial base as the least integer 1/a simplifies the equation:
p[x_,a_,b_,c_]= x+x^(Log[b]/Log[a])+x^(Log[c]/Log[a])1(1/a+1/b+1/c-1)
In this approach we can find Fuchsian triangle groups for the two cubic Pisots:
x^3-x-1
x^3-x^2-1

First cubic:triangle group < 0,E^2,E^3>BaseE
q[x_] = x^3 - x - 1
1 - x + x^3
p[x_] = -ExpandAll[x^3*q[1/x]]
-1 + x^2 + x^3
Solve[{Log[c] == 3, Log[b] == 2, a == Exp[-Infinity]}, {a, b, c}]
{{a -> 0, b -> E^2, c -> E^3}}

Second Cubic:triangle group < 0,E,E^3>BaseE
q[x_] = x^3 - x^2 - 1
-1 - x^2 + x^3
p[x_] = -ExpandAll[x^3*q[1/x]]
-1 + x + x^3
Solve[{Log[c] == 3, Log[b] == 1, a == Exp[-Infinity]}}, {a, b, c}]
{{a -> 0 b -> E, c -> E^3}}

This three matrix approach also gives a triangle group for the GoldenRatio:< 0,E,E^2>BaseE
q[x_] = x^2 - x - 1
-1 - x + x^2
p[x_] = -ExpandAll[x^2*q[1/x]]
-1 + x + x^2
Solve[{Log[c] == 2, Log[b] == 1, a == Exp[-Infinity]}}, {a, b, c}]
{{a -> 0, b -> E, c -> E^2}}

The quartic minimal Pisot gives:< 0,E,E^4>BaseE
q[x_] = x^4 - x^3 - 1
-1 - x^3 + x^4
p[x_] = -ExpandAll[x^4*q[1/x]]
-1 + x + x^4
Solve[{Log[c] == 4, Log[b] == 1, a == Exp[-Infinity]}, {a, b, c}]
{{a -> 0, b -> E, c -> E^4}}

Using the integer zero in a Fuchsian triangle group gives a new table: ( beta integer group representations)
TableForm[{{a, b, c},
{0, E, E^2},
{0, E, E^3},
{0, E^2, E^3},
{0, E, E^4}}]
The quintic/ pentic minimal Pisot: x^5-x^4-x^3+x^2-1
requires at least four Moran matrices.
If we make (represent) Riemannian level hyper-triangular groups as four integers:
<a,b,c,d>
<2,3,5,-30>
<2,3,7,42>

q[x_] = x^5 - x^4 - x^3 + x^2 - 1
-1 + x^2 - x^3 - x^4 + x^5
p[x_] = -ExpandAll[x^5*q[1/x]]
-1 + x + x^2 - x^3 + x^5
Solve[{Log[d] == 5, Log[c] == -3, Log[b] == 2, Log[a] == 1}, {a, b, c, d}]
{{a -> E, b -> E^2, c -> 1/E^3, d -> E^5}}
That gives the hyper triangle group:
<E,E^2,1/E^3,E^5>BaseE
instead of the expected:
<0,E,E^5>
While the three and four matrix Moran approaches answer some questions,
the approach also leaves a lot of questions unanswered.


(Mathematica program)
(* Fuchsian three matrix Moran:
1) Det[A]+Det[b]+Det[c]=1
as 1/n+1/m+1/l=1
2) Det[B]=Det[A]^b
Det[C]=Det[A]^b
3) Det[A]^a+Det[A]^b+Det[A]-10 as Det[A]=x
x^a+x^b+x-1=0 such that a≥b
)

(*first case: <3,3,3> triangle group)
Solve[(1/3)^a == 1/3, a] /. C[1] -> 0
Solve[(1/3)^b == 1/3, b] /. C[1] -> 0
(* 3*x-1 polynomial*)
Solve[x + x + x - 1 == 0, x]
(Second case:<2,3,6> or <2,6,3> Hexagons tiling)

Solve[(1/2)^a == 1/6, a] /. C[1] -> 0
Solve[(1/2)^b == 1/3, b] /. C[1] -> 0
(* x^(Log[6]/Log[2])+x^(Log[3]/Log[2])+x-1 polynomial*)
FindRoot[
x^a + x^b + x - 1 == 0 /. a -> Log[6]/Log[2] /. b -> Log[3]/Log[2], {x, 1.99}]
(* third case: <2,4,4> squares*)
Solve[(1/2)^a == 1/4, a] /. C[1] -> 0
Solve[(1/2)^b == 1/4, b] /. C[1] -> 0
(* 2*x^2+x-1 polynomial*)
FindRoot[
x^a + x^b + x - 1 == 0 /. a -> Log[4]/Log[2] /. b -> Log[4]/Log[2], {x, 1.99}]
q0[x_] = 2*x^2 + x - 1
NSolve[q0[x] == 0, x]
p0[x_] = ExpandAll[x^2*q0[1/x]]
NSolve[p0[x] == 0, x]
(* fourth case: Bonacci-Rauzy: a=3, b=2: polynomial: x^3+x^2+x-1*)

q[x_] = x^3 + x^2 + x - 1
p[x_] = ExpandAll[x^3*q[1/x]]
NSolve[p[x] == 0, x]
(* Riemannian generalization to include <2,3,5> and <2,3,7>*)
(* \
x^a+x^b+x-1=c: such that c>0,c=0,c<0*)
(* elliptic case Dodecahedron \
exceptional group: <2,3,5>*)
Together[1/2 + 1/3 + 1/5 - 1]
Solve[(1/2)^a == 1/5, a] /. C[1] -> 0
Solve[(1/2)^b == 1/3, b] /. C[1] -> 0
(* Polynomial:x^(Log[5]/Log[2])+x^(Log[3]/Log[2])+x-1=1/30 )
FindRoot[
x^a + x^b + x - 1 == 1/30 /. a -> Log[5]/Log[2] /. b -> Log[3]/Log[2], {x,
1.99}]
q5[x_] = x^(Log[5]/Log[2]) + x^(Log[3]/Log[2]) + x - 1 - 1/30
p5[x_] = ExpandAll[x^(Log[5]/Log[2])*q5[1/x]]
N[%]
FindRoot[N[p5[x]] == 0, {x, 2}]
( hyperbolic case: <2,3,7>*)
Together[1/2 + 1/3 + 1/7 - 1]
Solve[(1/2)^a == 1/7, a] /. C[1] -> 0
Solve[(1/2)^b == 1/3, b] /. C[1] -> 0
(* Polynomial:x^(Log[7]/Log[2])+x^(Log[3]/Log[2])+x-1=(1/42) )
FindRoot[
x^a + x^b + x - 1 == -(1/42) /. a -> Log[7]/Log[2] /. b -> Log[3]/Log[2], {x,
1.99}]
q7[x_] = x^(Log[7]/Log[2]) + x^(Log[3]/Log[2]) + x - 1 + 1/42
p7[x_] = ExpandAll[x^(Log[7]/Log[2])*q7[1/x]]
N[%]
FindRoot[N[p7[x]] == 0, {x, 2}]
( end*)
Wait while more posts are being loaded