Finding new roots to a triple pisot polynomial:
I discovered this set of polynomials a couple of days ago:
Special roots:
{-0.662358978622373` - 0.5622795120623013` I, -0.662358978622373` +
0.5622795120623013` I, -0.1557688521622851` + 0.8547594579428396` I,
0.8181278307846581` + 0.29247994588053833` I}
I’ve looked at the special root {1,5}, and {2,3} Moran solutions
and they gives s=2 fractals( overlapping). I haven’t found a tiling.
These n=3 120 degree solutions aren’t the only ones:
n=6 60 degrees also gives special roots.
in general:
p[x_, n_] =
FullSimplify[
ExpandAll[(x^3 - x - 1)*(x^3 - Exp[I*2*Pi/n]*x - 1)*(x^3 +
Exp[I*2*Pi/n]*x - 1)]]
Table[ListPlot[{Re[x], Im[x]} /. NSolve[p[x, n] == 0, x],
PlotStyle -> Red], {n, 1, 15, 1/3}];
Show[%, PlotRange -> All]
The roots form three circles with radius of about 1/3.
(* mathematica*)
(* special case tripisot*)
FullSimplify[
ExpandAll[(x^3 - x - 1)*(x^3 - Exp[I*2*Pi/3]*x - 1)*(x^3 + Exp[I*2*Pi/3]*x -
1)]]
(* solved*)
ll = {Re[x], Im[x]} /.
NSolve[(-1 - x + x^3) (1 + x^2 ((-1)^(1/3) - 2 x + x^4)) == 0, x] ListPlot[ll, PlotStyle -> Red]
Table[Sqrt[ll[[i]].ll[[i]]], {i, Length[ll]}]
(* special roots*)
{{-0.662358978622373`, -0.5622795120623013`} \
{-0.662358978622373`, 0.5622795120623013`}, {-0.1557688521622851`,
0.8547594579428396`}, {0.8181278307846581`, 0.29247994588053833`}}
(* forming matrices of all the roots*)
m = {{Re[x], Im[x]}, {-Im[x],
Re[x]}} /.
NSolve[(-1 - x + x^3) (1 + x^2 ((-1)^(1/3) - 2 x + x^4)) == 0, x] Table[Det[m[[i]]], {i, 9}]
(* doing Moran powers for all the roots*)
Table[
Table[{n, k, i,
Det[MatrixPower[m[[i]], n]] + Det[MatrixPower[m[[i]], k]]}, {i, 9}], {n, 1,
5}, {k, 1, n}]
(* finding roots that have unitary ( one) two matrix Morans*)
Delete[Union[
Flatten[
Table[Union[
Table[
If[Abs[
Det[MatrixPower[m[[i]], n]] + Det[MatrixPower[m[[i]], k]] - 1.0] <
0.01, {n, k, i, m[[i]]}, {}], {i, 9}]], {n, 1, 5}, {k, 1, n}],
2]], 1]
c = {3, 4, 6, 7}
(* showing the spacial roots*)
w =
Table[x /.
NSolve[(-1 - x + x^3) (1 + x^2 ((-1)^(1/3) - 2 x + x^4)) == 0,
x][[c[[i]]]], {i, 4}]
{-0.662358978622373` - 0.5622795120623013` I, -0.662358978622373` +
0.5622795120623013` I, -0.1557688521622851` + 0.8547594579428396` I,
0.8181278307846581` + 0.29247994588053833` I}
(* end*)
IFS program:
(*Mathematica program*)Clear[f, dlst, pt, cr, ptlst, M, r, p, rotate]
allColors = ColorData["Legacy"][[3, 1]];
firstCols = {"Red", "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 4 Mar 2018©*)
(*IFS program type*)
{m1, m2} =
Table[MatrixPower[{{-0.1557688521622851`,
0.8547594579428396`}, {-0.8547594579428396`, -0.1557688521622851`}},
i], {i, 1, 5, 4}]
A = {{0, 1}, {1, 0}}
a1 = Expand[(A.m1.{x, y}).A.m1.{x, y}] // Chop
a2 = Expand[(A.m2.{-x, -y}).(A.m2.{-x, -y})] // Chop
sc = FullSimplify[
ExpandAll[Sqrt[1/FullSimplify[ExpandAll[(a1 + a2)/(x^2 + y^2)]]]]]
f[1, {x_, y_}] = m1.{x, y} + {-1, 0}
f[2, {x_, y_}] = A.m2.{x, y} + {1, 0}
pt = {0.5, 0.5};
{p1, p2} = {Det[m1], Det[m2]}
dlst = Table[ Which[(r = Random[]) <= p1, 1, r <= 1, 2]
, {n, 90000}];
cr[n_] := cr[n] = cols[[n ]];
ptlst = Point[
Developer`ToPackedArray[Table[pt = f[dlst[[j]], pt], {j, Length[dlst]}]],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]]; Graphics[{PointSize[.001], ptlst}, AspectRatio -> 1, ImageSize -> 1000,
Background -> Black]
(*end program*)
https://i.pinimg.com/564x/45/34/d5/4534d548d14c6df840f4e14158f5dfc1.jpg
--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)
