¿Cómo encontrar los puntos de Misiurewicz sin resolver polinomios enormes? (Conjunto de Mandelbrot)

Question

Aquí hay un gráfico de 17.723 puntos de Misiurewicz. El código de abajo genera un conjunto de polinomios u[m,n], cuyas raíces tienen periodicidad (m-n) a partir de la iteración n. Me detuve en 17.723 puntos porque para obtener más por este método tuve que generar y resolver $2^{11}$ -de orden. En otras palabras, he llegado al límite práctico de mi método.

Así que mi pregunta es: ¿Hay alguna forma de encontrar más puntos de Misiurewicz sin tener que resolver polinomios gigantes?

Esto se relaciona con otro Pregunta sobre el punto real de Misiurewicz más a la derecha .

Código de Mathematica:

z[n_, c_] := If[n > 0, z[n - 1, c]^2 + c, c];
ord = 8;
(* Calculate u[m,n] up to m==ord *)
Do[Do[
   If[n > 0, t = Expand[z[m, c] - z[n, c]], t = Expand[z[m - 1, c]]];
   p = m - n;
   Do[Do[If[((i != m) || (j != n)) && (Mod[p, i - j] == 0),
      While[(tt = PolynomialQuotientRemainder[t, u[i, j], c])[[2]] == 0, t = tt[[1]]]], {j, 0, Min[n, i - 1]}], {i, 1, m}];
   u[m, n] = t, {n, 0, m - 1}], {m, 1, ord}];
Print["Polynomial orders : ", Table[Exponent[u[m, n], c], {m, 1, ord}, {n, 0, m - 1}] // MatrixForm];

(* Compile numerical roots of u[m,n>0], which are c's on the edge of the M-set *)
plotOrd = 8;
$MaxRootDegree = Max[$MaxRootDegree, 2^(plotOrd - 1)];
rts = {};
Do[
  Do[
   s[m, n] = Solve[u[m, n] == 0, c] // N;
   rts = Append[rts, c /. s[m, n]], {n, 1, m - 1}], {m, 1, plotOrd}];
rts = Flatten[rts];
Print["Number of Plot points : ", Length[rts]];
Print[ListPlot[Transpose[{Re[rts], Im[rts]}],PlotStyle ->PointSize[Small]]];

Estos ajustes producirán un gráfico en pocos segundos. El jpeg de arriba tardó un rato y se generó con

ord=11;
plotOrd=11;

y

Print[ListPlot[Transpose[{Re[rts], Im[rts]}],PlotStyle ->PointSize[Tiny]]];

Answer 1

Usando métodos numéricos, como:

1. Dominios de Misiurewicz
2. Método de Newton para los puntos de Misiurewicz