Finding Real Roots and Determining Range

Question

I am interested in determining the minimum and maximum values of the real roots of polynomials of form $P(x)=\sum_{k=0}^n a_{k} x^k$ where $n$ will have a defined value (say 3,4,5...) and $a_k$ are chosen from the set $\{-1,1\}$ with equal probability.

I have tried creating a table of the roots, and then using MinMax; here is my (bad) attempt (with $n=3$):

T = Table[Roots[Sum[RandomChoice[{-1, 1}] x^k, {k, 0, 3}] == 0, x], 25] 
MinMax[T]

Unfortunately, Roots gives both the real and imaginary roots, I would only like the real roots . Also, MinMax cannot work on the table $T$ when the roots are not presented as a list (they have $||$ in between each root).

Any suggestions/help with this issue is immensely appreciated. Thank You!

Answer 1

Try something like

x /. Solve[Sum[RandomChoice[{-1, 1}] x^k, {k, 0, 3}] == 0, x, Reals] 

instead of your Roots expression. Use NSolve if you want the numerical value of the roots, rather than a symbolic representation.

For instance:

t = Table[x /. NSolve[Sum[RandomChoice[{-1, 1}] x^k, {k, 0, 3}] == 0, x, Reals], 4500];
realroots = DeleteDuplicates@Flatten@t

(* Out: {-1., 1., 1.83929, -1.83929, 0.543689, -0.543689} *)

As you can see, these seem to be the only admissible real root values. By inspection, or using MinMax, you obtain the largest and smallest one:

MinMax@realroots
(* Out: {-1.83929, 1.83929} *)

---

Consider also that you can pretty simply enumerate all possible polynomials of your desired form:

Tuples[{-1, 1}, {4}].{1, x, x^2, x^3}
(* Out:
{-1 - x - x^2 - x^3, -1 - x - x^2 + x^3, -1 - x + x^2 - x^3, 
 -1 - x + x^2 + x^3, -1 + x - x^2 - x^3, -1 + x - x^2 + x^3, 
 -1 + x + x^2 - x^3, -1 + x + x^2 + x^3,  1 - x - x^2 - x^3, 
  1 - x - x^2 + x^3,  1 - x + x^2 - x^3,  1 - x + x^2 + x^3, 
  1 + x - x^2 - x^3,  1 + x - x^2 + x^3,  1 + x + x^2 - x^3, 
  1 + x + x^2 + x^3}
*)

Flatten[x /. NSolve[# == 0, x, Reals] & /@ %] // MinMax
(* Out: {-1.83929, 1.83929} *)

Answer 2

To find the exact values for min and max roots

roots = DeleteDuplicates@
    Flatten[x /. 
        Solve[# == 0, x, Reals] & /@
      (Tuples[{-1, 1}, {4}].{1, x, x^2, x^3})] //
   SortBy[#, N] &;

{min, max} = roots[[{1, -1}]] // ToRadicals

The approximate numeric values are as shown by @MarcoB

{min, max} // N

(*  {-1.83929, 1.83929}  *)