3
$\begingroup$

I am a newbie using Mathematica. I wrote this code to plot the roots of Littlewood polynomials, based on the structure of other programming languages. But I'm sure Mathematica has tools to do it in a more condensed and efficient way. Could you guide me how to do it?

poly[exp_, var_] :=
  Times @@@ Tuples[var^Range[0, exp]] //   
  Tuples[{1, -1}, Length@#].# &;

aux[num_] := lista[[num]];

pts = List[];

For[i = 1, i < 15, i++, lista = poly[{i}, {x}];
   For[j = 1, j < Length[lista] + 1, j++,
      pts = Join[pts, ({Re[#1], Im[#1]} &) /@ (x /. 
         NSolve[aux[j] == 0, x])];
   ]
];

graphi = ListPlot[puntos,
         PlotRange -> {{-2.2, 2.2}, {-2.2, 2.2}},
         AspectRatio -> Automatic,
         PlotStyle -> {PointSize[0.0000001],
            Opacity[0.05],
            Yellow
         },
         Axes -> False,
         Background -> Black,
         ImageSize -> 1000,
         GridLines -> {{-2, -1, 0, 1, 2}, {-2, -1, 0, 1, 2}}
];

Export["/Animaciones/Littlewood/14.png", graphi];

Use aux[num_]:=lista[[num]]; because ({Re[#1], Im[#1]} &) /@ (x /.NSolve[lista[[j]] == 0, x]) gave me an error, and pts=List[]; to have an empty list. As seen in the first For this code generates the roots of the Littlewood polynomials with n = 14

Also, is it normal for Mathematica on Linux (ubuntu 20.04) to use only one thread at a time in its calculations? I think a lot of processing power is wasted.

$\endgroup$
  • 3
    $\begingroup$ You can use something like ReIm@Values@NSolve[ lista[[j]] == 0, x] instead as no need for separate Re andIm, and ReIm is listable. You should consider using a Table, or Reap+Sow+Flatten to achieve what's going on in the loops. $\endgroup$ – flinty Nov 16 at 17:47
5
$\begingroup$

The roots can be represented directly and exactly with Root objects; there is no need to invoke Solve or NSolve explicitly. For a given tuple t we can list them with

F[t_] := Array[Root[#^Range[0, 11].t &, #] &, 11]

or, more generally for arbitrary polynomial degree,

F[t_] := With[{n = Length[t] - 1},
  Array[Root[#^Range[0, n].t &, #] &, n]]

Example:

F[{1, 1, -1}]
(*    {1/2 (1 - Sqrt[5]), 1/2 (1 + Sqrt[5])}    *)

F[{-1, 1, 1, -1, -1, -1, 1, -1, -1, 1, -1, -1}]
(*    {-1.52929, -1.13608, -1., -0.461159 - 0.792192 I, -0.461159 + 0.792192 I,
       0.300042 - 1.08437 I, 0.300042 + 1.08437 I, 0.646434 - 0.281355 I,
       0.646434 + 0.281355 I, 0.847365 - 0.608848 I, 0.847365 + 0.608848 I}    *)

Plot them with ComplexListPlot:

ComplexListPlot[F /@ Tuples[{-1, 1}, 12]]

enter image description here

Alternatively (faster), by taking the product of all of these polynomials and setting this product to zero, we can find all solutions in one go:

With[{n = 11},
  ComplexListPlot[x /. Solve[Times @@ (1 + Tuples[{-1, 1}, n].x^Range[n]) == 0, x]]]

enter image description here

| improve this answer | |
$\endgroup$
4
$\begingroup$

I thought I'd seen this before!

In-fact you can do all of this and plot it in under 128 characters:

Graphics[{PointSize[Tiny],Point@Flatten[((ReIm[z]/.#)&/@NSolve[z^Range[0,11].#==0,z])&/@Tuples[{-1,1},12],1]}]

enter image description here

The credit goes to Yuncong Ma's Honorable Mention Entry from the 2012 one-liner competition. The terse syntax is explained in the video above, but happy to help break it down further if needed.

With regards to efficiency, I suspect there's improvements to be made - but the bulk of this is spent inside NSolve so perhaps unlikely..

| improve this answer | |
$\endgroup$
  • 1
    $\begingroup$ +1 With Manipulate: Manipulate[Graphics[{PointSize[Which[n < 4, Large, n < 6, Medium, n < 9, Small, True, Tiny]], Point@Flatten[((ReIm[z] /. #) & /@ NSolve[z^Range[0, n].# == 0, z]) & /@ Tuples[{-1, 1}, n + 1], 1]}], {{n, 11}, Range[11]}] $\endgroup$ – Bob Hanlon Nov 16 at 20:50

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.