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]

(

Mandelbrot set PC17 polynomial*)

sw[c_] = p3[c]/p1[c] - (3/2)

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 theMandelbrot 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*) 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

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

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.

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.

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

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

Post has attachment

(* Mandelbrot_fixed point on PC29*)

Post has attachment

Inside of a low iteration Mandelbrot set:

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

#Fractal #Math #Art #Space

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

*__*#Fractal #Math #Art #Space

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

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

This is the points that do not escape.

*__*#Fractal #Math #Art #Space

Post has attachment

Here is +Roger Bagula's Julia stuffed inside the unit circle.

https://plus.google.com/101799841244447089430/posts/4RiPw4e91Ab

#Fractal #Math #Art #Space

https://plus.google.com/101799841244447089430/posts/4RiPw4e91Ab

*__*#Fractal #Math #Art #Space

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}]

(

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](

ImageSize -> 1000, Background -> Black, PlotRange -> {{-4, 4}, {-4, 4}}];

Export["8group_G2.jpg", g2]

Export["8group_G2_halfplanetodisk.jpg", g3a]

(

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**)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 ((-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

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