ToNumberField won't recognize Root as an explicit algebraic number

Question

Bug fixed in 10.0.0

---

In Mathematica 9.0.1, it appears that ToNumberField will not always recognize a Root object as an explicit algebraic number.

ToNumberField[
    Root[{ 1 - #1 + #1^2 - #1^3 + #1^4 - #1^5 + #1^6 &, 
           #1^5 + #1^3 #2 + #1 #2^2 + #2^3 - #1 #2^3 + #1^2 #2^3 - #1^3 #2^3 + #1^4 #2^3 
          - #1^5 #2^3 - #1^4 #2^4 - #1^2 #2^5 - #2^6 &},  {6, 6}] ]

ToNumberField::nalg: 
"Root[{1 -#1 + #1^2 - #1^3 + #1^4 - #1^5 + #1^6&, 
        #1^5 + #1^3 #2 + #1 #2^2 + #2^3 - #1 #2^3 + #1^2 #2^3 -#1^3 #2^3 + #1^4 #2^3
       - #1^5 #2^3 - #1^4 #2^4 - #1^2 #2^5 - #2^6 &}, {6,6}]
  is not an explicit algebraic number. >>"

A different root of the same polynomial works just fine:

ToNumberField[
    Root[{1 - #1 + #1^2 - #1^3 + #1^4 - #1^5 + #1^6 &, 
          #1^5 + #1^3 #2 + #1 #2^2 + #2^3 - #1 #2^3 + #1^2 #2^3 - #1^3 #2^3 + #1^4 #2^3 
          - #1^5 #2^3 - #1^4 #2^4 - #1^2 #2^5 - #2^6 &},  {6, 1}] ]

AlgebraicNumber[Root[1 + #1 + #1^2 + #1^3 + #1^4 + #1^5 + #1^6 &, 2], {0, 1, 0, 0, 0, 0}]

Is this a bug, and is there any way I can work around it?

Edit: In case it matters, that first Root expression will FullSimplify to 1.

Answer 1

This is caused by a bug in RootReduce for Root objects representing last coordinates of solutions of triangular systems. The bug affects cases where the last coordinate of the solution is real, but some of the other coordinates are not real. Thanks for pointing it out.

The problem can be fixed with the following patch (you can put it in your init.m file).

rootReduceFix[r:Root[fs_List, ks_List]] :=
   Module[{X, vars, polys, rts, nr, prec=20},
      vars = X /@ Range[ Length[fs]];
      polys = # @@ vars& /@ fs;
      res = Last[polys];
      Do[ res = Resultant[ res, polys[[i]], vars[[i]]];
          res = Times @@ (First /@ FactorSquareFreeList[res]),
          {i, Length[polys] - 1, 1, -1}];
      rts = Last[vars]/.Solve[ res==0, Last[vars]];
      While[ Length[rts] != 1,
             nr = N[r, prec];
             rts = Select[ rts, # - nr == 0&];
             prec*=2];
      First[rts]]

problemRootQ[r_] := Head[r] === Root && Length[r] == 2 && ListQ[r[[1]]] &&
   (Head[#] === Complex && Im[#] == 0 &[N[r]])

rootReduceFixFlag = True;

Unprotect /@ { RootReduce, ToNumberField};

RootReduce[e_] /; rootReduceFixFlag :=
   Block[{ rootReduceFixFlag=False},
      RootReduce[ e/.(r_?problemRootQ) :> rootReduceFix[r]]]

ToNumberField[args__] /; rootReduceFixFlag :=
   Block[{ rootReduceFixFlag = False},
      ToNumberField @@ ( {args}/.(r_?problemRootQ) :> rootReduceFix[r])]

Protect /@ { RootReduce, ToNumberField};