[Math] How to find Misiurewicz Points without solving huge polynomials? (Mandelbrot Set)

Question

Here is a plot of 17,723 Misiurewicz Points. The code below generates a set of polynomials u[m,n], the roots of which have periodicity (m-n) starting at iteration n. I stopped at 17,723 points because to get more by this method I had to generate and solve $2^{11}$-order polynomials. In other words, I hit the practical limit of my method.

So my question is: Is there any way I can find more Misiurewicz points without having to solve giant polynomials?

This relates to another Question about the right-most real Misiurewicz Point.

Mathematica code:

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

These settings will produce a plot in few seconds. The jpeg above took a while and was generated with

ord=11;
plotOrd=11;

and

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

Answer 1

Using numerical methods, like:

1. Misiurewicz domains
2. Newton's method for Misiurewicz points