Transform Root objects into Trigonometric expressions

Question

Consider the Root objects

roots = Table[Root[-1 + 27 #1^2 - 162 #1^4 + 243 #1^6 &, i],{i,1,6}]

These can be expressed in terms trigonometric functions as follows

trig = 
  {-2/3 Cos[Pi/18], -2/3 Cos[5 Pi/18], -2/3 Cos[7 Pi/18], 
    2/3 Cos[7 Pi/18], 2/3 Cos[5 Pi/18], 2/3 Cos[Pi/18]}

This can be checked Numerically, but also exactly using the following expression:

And @@ 
  MapThread[
    PossibleZeroQ[ToNumberField[#1 - #2], Method -> "ExactAlgebraics"] &, 
    {roots, trig}]

True

Is there a way to have Mathematica translate between these two things? I have not been able to make FullSimplify do it. Does anyone know of something like a RootToTrig function?

---

Example (by Vladimir Reshetnikov):

Root[1 - 420 # + 32373 #^2 - 33276 #^3 + 11322 #^4 - 1296 #^5 + 9 #^6 &, 2]

should be converted to

Sin[π/36]^2 Sin[5π/36]^2 / (Sin[7π/36]^2 Sin[2π/9]^2)

---

Further Examples (by Matthew Titsworth):

Since more examples have been asked for, here is the function that spurred the original asking of this question:

Y[r_, p_] := Table[{(-1)^i Cos[(i^2 r \[Pi])/(2 p + 1)], (-1)^(i-1)^2 Sin[(i^2 r \[Pi])/(2 p + 1)]}, {i, 1, p}]

This contains plenty of examples (e.g. r=1,p=7, r=3,p=4) which do not return to their original form under the transformation

FullSimplify[ComplexExpand[ToRadicals[ToNumberField[Y[r,p],All]]]]

Answer 1

Disclaimer: This is not a full answer, but perhaps it's a start.

From an algebraic stand point this seems like a very hard problem. I attacked it with a more brute force approach. I guess a basis and use LatticeReduce to try to find a Diophantine relation.

Note this code only tries to identify roots as the product of integral powers of trig. If it returns an answer you can be assured it's correct. If it returns $Failed, you may not draw any conclusions.

RootToTrig[r_, max_:36] := RootToTrig[r, Range[max]]

RootToTrig[r_, denomGuesses_List] := Module[{redroot, Nr},
    redroot = RootReduce[Sign[r]r];
    Nr = N[Log[Abs[r]], 30];
    Catch[
        If[Im[r] != 0, Throw[$Failed]];
	Do[iRootToTrig[redroot, Nr, Sign[r], n], {n, denomGuesses}];
	$Failed
    ]
]

iRootToTrig[r_, Nr_, sign_, n_] := Block[{tbl, V, pos, root},
    tbl = Join[Prime[Range[8]], Table[Sin[k π/n], {k, n}]];
    tbl = Log[DeleteCases[tbl, 0|1]];
    tbl = Union@Replace[tbl, t_Times :> Select[t, FreeQ[Head[#], Integer|Rational]&], {1}];

    While[Length[tbl] > 1,
        V = LatticeBasis[tbl, Nr];
        (* if First[V] == 0, then we have found a trig identity, we will ignore it *)
        If[First[V] != 0, 
            V = Rest[V]/First[V];
            Break[]
        ];

        pos = Flatten[Position[V, Except[0], {1}]]-1;
        tbl = Delete[tbl, Last[pos]];
    ];

    (* uncomment extra conditions below for integer exponents only *)
    If[Length[tbl] <= 1 (* || !VectorQ[V, IntegerQ] || Max[Abs[V]] > 20 *),
        Return[]
    ];

    root = Exp[V.tbl];
    If[Abs[N[r, 40] - N[root, 40]] < 1.*^-38 && RootReduce[root] == r,
        Throw[sign root]
    ]
]

LatticeBasis[a_List, b_] := Block[{A, prec, basis}, 
    A = Prepend[a, -b];
    prec = Ceiling[Precision[A]]; 
    basis = Transpose[Prepend[IdentityMatrix[Length[A]], Round[10^prec A]]];
    Rest[First[LatticeReduce[basis]]]
]

This code works on all provided examples:

RootToTrig /@ Table[Root[-1 + 27 #1^2 - 162 #1^4 + 243 #1^6 &, i], {i, 1, 6}]

{-2/3 Cos[π/18], -Csc[π/9]Sec[π/18]/(4 Sqrt[3]), -2/3 Sin[π/9], 2/3 Sin[π/9], Csc[π/9]Sec[π/18]/(4 Sqrt[3]), 2/3 Cos[π/18]}

RootToTrig[Root[1 - 420 # + 32373 #^2 - 33276 #^3 + 11322 #^4 - 1296 #^5 + 9 #^6 &, 2]]//AbsoluteTiming

{3.447089, 1/96 (Sqrt[3]-1)^2 Cos[π/18]^4 Sec[π/9]^4 Sec[5π/36]^4}

Also note if we have a hunch on what the possible denominator should be (or have multiple guesses), you can provide those for a speed up:

RootToTrig[Root[1 - 420 # + 32373 #^2 - 33276 #^3 + 11322 #^4 - 1296 #^5 + 9 #^6 &, 2], {36}]//AbsoluteTiming

{0.570626, 1/96 (Sqrt[3]-1)^2 Cos[π/18]^4 Sec[π/9]^4 Sec[5π/36]^4}

---

A more robust approach is to use the AskConstants package [download link] [WTC presentation]: