Post has attachment
PC9 Schwarzian derivative roots and implicit:
For Möbius transforms the Schwarzian derivative is zero:
as an Kleinian group generated set the Mandelbrot set has special
lines along the Schwarzian derivatives and special roots as well.
PC9 has a lot of roots and is close as I can get with this method to an actual Mandelbrot set:
(* Mathematica*)
(* Schwarzian derivative in the Kleinian group of the Mandelbrot set As PC19 polynomial*)
Clear[f, z, x]
(https://oeis.org/A137560*)
f[z_] = z^2 + x;
g = Join[{1}, ExpandAll[NestList[f, x, 7]]]; a =
Table[CoefficientList[g[[n]], x], {n, 1, Length[g]}];
Flatten[a] Table[Apply[Plus, CoefficientList[g[[n]], x]], {n, 1, Length[g]}];
p[x_] = NestList[f, x, 9][[9]]
p1[c_] = D[p[c], {c, 1}]
p2[c_] = D[p[c], {c, 2}]
p3[c_] = D[p[c], {c, 3}]
( Linear fractal transform condition of zero Schwarzian derivatives in the
Mandelbrot set PC17 polynomial*)
sw[c_] = p3[c]/p1[c] - (3/2)(p2[c]/p1[c])^2
pc3sw = Join[{Re[c], Im[c]} /. NSolve[sw[c] == 0, c], {Re[c], Im[c]} /.
NSolve[p[c] == 0, c]];
g1 = ListPlot[pc3sw, PlotStyle -> {PointSize[0.0025], Red}, ImageSize -> 1000,
PlotRange -> {{-2.3, 1}, {-1.65, 1.65}}]
Clear[x, y, a, b, f, g, z, a0, t, nl, nr]
p[x_] = sw[x]
z = x + I*y;
f[x_, y_] = Re[(p[z])];
gg = ContourPlot[f[x, y] == 0, { x, -2.1, 1.1}, { y, -1.7, 1.7},
PlotPoints -> {100, 100}, ContourStyle -> {White}, ImageSize -> 1000,
Axes -> False, Frame -> False, Background -> Black]
Show[{gg, g1}]
g1 = ListPlot[pc3sw, PlotStyle -> {PointSize[0.0025], Red}, ImageSize -> 1000,
PlotRange -> {{-2.3, 1}, {-1.65, 1.65}}]
( end*)
Photo

Post has attachment
(* Mandelbrot_fixed point on PC17*)
g[x_, c_] =
x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x \
+ x^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2 - x^2 - c

s=4.3621
Photo

Post has attachment
Mandelbrot set:
For the traditional Mandelbrot set the log-log curve is smoother:
s=3.07047
The PC17 Julia set is more chaotic than the Mandelbrot set.
Photo

Post has attachment
Mandelbrot Julia of PC17:
g[x_] = x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x + (x \
+ (x + (x + (x + x^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2)^2
Dimension of the set in 2*n log-log terms is:
s=3.69449
Photo

Post has attachment
(* Mandelbrot_fixed point on PC29*)
Photo

Post has attachment

Post has attachment
Here is what I am getting for +Roger Bagula 's formula over here:

https://plus.google.com/110803890168343196795/posts/VjZEPR8wKe2

This is the points that do not escape.

__
#Fractal #Math #Art #Space
Photo

Post has attachment

Post has attachment
An complexified vector G_2(7 group)completed as an 8 group:
The vector representation of G_2 as 7 2 vectored is on page 151 of the classic:
Semi-Simple Lie Algebras and their representations by Robert N. Cahn.
He points out that the B_3 7 vector representation contains is contained in the /G_2 vectors.
I made the two vectors complex and used a Picard group projection.
I get a pretty standard 4 Lattice and an half plane to disk strip.
(* mathematica*)
Clear[cr, cols, cr2, cr3, cr4]
allColors = ColorData["Legacy"][[3, 1]];
firstCols = {"White", "AliceBlue", "LightBlue" , "LightSkyBlue", "Cyan",
"Cerulean", "ManganeseBlue", "DodgerBlue" , "Blue", "Navy", "Purple",
"Raspberry", "Magenta", "Pink", "Tomato", "Red", "DarkOrange", "Orange",
"DeepNaplesYellow", "Gold", "Banana", "Yellow", "LightYellow", "Orange",
"Pink", "LightPink", "Yellow", "LightYellow", "LightPink", "White",
"DeepNaplesYellow", "Orange", "DarkOrange", "Tomato", "Red", "Tomato",
"Pink", "LightPink", "DeepNaplesYellow", "Orange", "DarkOrange", "Tomato",
"White", "Pink", "Banana", "LightBlue", "DodgerBlue", "Cyan", "White",
"Purple", "DarkOrchid", "Magenta", "ManganeseBlue", "DeepNaplesYellow",
"Orange", "DarkOrange", "Tomato", "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 + 8]];
cr3[n_] := cr3[n] = cols[[n + 16]];
cr4[n_] := cr4[n] = cols[[n + 24]];
cr5[n_] := cr5[n] = cols[[n + 36]]
Clear[w, ww, n, m, a0, a, b, A, B, r]
bi[1] = I; bi[2] = 1 - I; bi[3] = -1 + 2*I; bi[4] = 0; bi[5] = 1 - 2*I;
bi[6] = -1 + I; bi[7] = -I;
s[1] = {{1, bi[1]}, {0, 1}};
s[2] = {{1, bi[2]}, {0, 1}};
s[3] = {{1, bi[3]}, {0, 1}};
s[4] = {{1, bi[4]}, {0, 1}};
s[5] = {{1, bi[5]}, {0, 1}};
s[6] = {{1, bi[6]}, {0, 1}};
s[7] = {{1, bi[7]}, {0, 1}};
s[8] = {{1, 0}, {-2*I, 1}}
Table[Det[s[i]], {i, 8}]

Table[Tr[s[i]], {i, 8}]



(torus invariant)
Apply[Dot, Table[s[i], {i, 8}]] // Chop
Det[%]
(* Casimir quadratic invariant*)
Sum[s[i].s[i], {i, 8}] // Chop
(* the Möbius transforms : Kleinian group in SL(2,c)*)

{a, b, c, d, A0, B0, C0, D0} = Table[N[s[i]], {i, 8}]

Affine[{z1_, z2_}] := 0.00001 Round[(z1/z2)/0.00001];
Children[{z_,
n_}] := {Affine[{a, b, c, d, A0, B0, C0, D0}[[#]].{z, 1}], #} & /@
Delete[Range[8], {5, 6, 7, 8, 1, 2, 3, 4}[[n]]];
aa1 = {Re[#[[1]]], Im[#[[1]]]} & /@
Nest[Union[Flatten[Children /@ #, 1]] &,
ParallelTable[{Affine[{a, b, c, d, A0, B0, C0, D0}[[i]].{0, 1}], i}, {i,
1, 8}], 8];
ll = Length[aa1]
Last[aa1]
aa = Delete[Union[aa1], Length[Union[aa1]]];

ListPlot[aa, AspectRatio -> Automatic, PlotStyle -> {Black, PointSize[0.001]},
ImageSize -> 1000, PlotRange -> {{-4, 4}, {-4, 4}}]

dlst = Table[1 + Floor[20*Norm[aa[[i]]]], {i, Length[aa]}];
Min[dlst]
Max[dlst]
ptlst = Point[Developer`ToPackedArray[aa],
VertexColors -> Developer`ToPackedArray[cr /@ dlst]];
g2 = Graphics[{PointSize[.001], ptlst}, AspectRatio -> Automatic,
ImageSize -> 1000, Background -> Black,
PlotRange -> {{-4, 4}, {-4, 4}}/2];
(* end limit set*)

(* Half plane to disk conformal map*)

bb = Delete[
Union[Table[{Im[-(1/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)) +
aa[[i, 1]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2) +
aa[[i, 2]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)] +
2 Re[aa[[i, 2]]/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)], -2 Im[
aa[[i, 2]]/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)] +
Re[-(1/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)) +
aa[[i, 1]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2) +
aa[[i, 2]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)]}, {i,
Length[aa]}]], Length[aa]];
bb1 = Delete[
Union[Table[{-(Im[-(1/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)) +
aa[[i, 1]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2) +
aa[[i, 2]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)] +
2 Re[aa[[i, 2]]/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)]), -2 Im[
aa[[i, 2]]/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)] +
Re[-(1/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)) +
aa[[i, 1]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2) +
aa[[i, 2]]^2/((1 + aa[[i, 1]])^2 + aa[[i, 2]]^2)]}, {i,
Length[aa]}]], Length[aa]];
dlst1 = Table[1 + Floor[6*Norm[bb[[i]]]], {i, Length[bb]}];
Min[dlst1]
Max[dlst1]
dlst2 = Table[1 + Floor[6*Norm[bb1[[i]]]], {i, Length[bb1]}];
Min[dlst2]
Max[dlst2]
ListPlot[{bb, bb1},
PlotStyle -> {{Yellow, PointSize[0.001]}, {Orange, PointSize[0.001]}},
ImageSize -> 1000, Axes -> True, PlotRange -> All];
ptlst2 :=
Point[Developer`ToPackedArray[bb],
VertexColors -> Developer`ToPackedArray[cr /@ dlst1]];
ptlst3 :=
Point[Developer`ToPackedArray[bb1],
VertexColors -> Developer`ToPackedArray[cr /@ dlst2]];

g3a = Graphics[{PointSize[.001](,ptlst3), ptlst2}, AspectRatio -> Automatic,
ImageSize -> 1000, Background -> Black, PlotRange -> {{-4, 4}, {-4, 4}}];
Export["8group_G2.jpg", g2]
Export["8group_G2_halfplanetodisk.jpg", g3a]
(end)
Photo
Photo
2/20/19
2 Photos - View album

Post has attachment
7-17 two cycle Herman rings Julia:
Another one that seems to show the two cycle effect:
t = N[Sqrt[3] + 1/Sqrt[3]];

a = 1/(2*t); abar = 1/(2*t);
b = (0.355534 - 0.337292*I); bbar = (0.355534 + 0.337292*I);

f[z_] = FullSimplify[
ExpandAll[N[Exp[I*2*Pi*t]]z^3(1 - abar*z)(1 - bbar*z)/((z - a)(z - b))]]
(z^3 ((-0.364623 +
0.931155 I) + ((0.52265 -
0.409674 I) - (0.0960654 - 0.0450491 I) z) z))/((0.0769754 -
0.0730259 I) + ((-0.57204 + 0.337292 I) + z) z)
https://i.pinimg.com/originals/91/a6/c5/91a6c502f63c9f8a2686651a01022a2b.jpg
Wait while more posts are being loaded