Phenomenon in finding "simplest" algebraic numbers

Questions
1

I noticed an interesting occurrence with RootApproximant[:
Find the RootApproximant[ for a given number; then find the RootApproximant[ for 1/that number and you get the exact same coefficients in reverse order. I tried it with different numbers that RootApproximant[:gives a polynomial type solution to, and it seemed to be true in all those cases.

Can anyone point me to a reference for that matter? I can’t be the first one to notice that!

Here I tried it with an approximation to E:

In[195]:= N[E, 30]

Out[195]= 2.71828182845904523536028747135

In[196]:= RootApproximant[2.71828182845904523536028747135]

Out[196]= Root[
 1 - 3 #1 - 7 #1^2 + 3 #1^3 - 5 #1^4 - 4 #1^5 - 2 #1^6 + 7 #1^7 + 
   2 #1^8 - 8 #1^9 - 2 #1^10 - 5 #1^11 - 4 #1^12 + #1^14 - 2 #1^15 - 
   2 #1^16 + #1^17 &, 3]

In[197]:= 1/%%

Out[197]= 0.367879441171442321595523770161

In[198]:= RootApproximant[0.367879441171442321595523770161]

Out[198]= Root[
 1 - 2 #1 - 2 #1^2 + #1^3 - 4 #1^5 - 5 #1^6 - 2 #1^7 - 8 #1^8 + 
   2 #1^9 + 7 #1^10 - 2 #1^11 - 4 #1^12 - 5 #1^13 + 3 #1^14 - 
   7 #1^15 - 3 #1^16 + #1^17 &, 2]

Here I tried it with an approximation to the MRB constant:

In[192]:= RootApproximant[0.18785964246206712024857897184]

Out[192]= Root[-1 - #1 + 33 #1^2 - 3 #1^3 + 27 #1^4 + 40 #1^5 + 
   5 #1^6 - 2 #1^7 - 27 #1^8 - 36 #1^9 + 2 #1^10 + 21 #1^11 + 
   21 #1^12 + #1^13 &, 3]

In[193]:= 1/m

Out[193]= 5.323123087503594008916986345

In[194]:= RootApproximant[5.323123087503594008916986345]

Out[194]= Root[-1 - 21 #1 - 21 #1^2 - 2 #1^3 + 36 #1^4 + 27 #1^5 + 
   2 #1^6 - 5 #1^7 - 40 #1^8 - 27 #1^9 + 3 #1^10 - 
   33 #1^11 + #1^12 + #1^13 &, 3]
2

I don’t see it. First there are slight difficulties with

In[59]:= RootApproximant[113.018]
Out[59]= 1/358 (20235 + 3 Sqrt[45452065])

In[58]:= RootApproximant[1/113.018]
Out[58]= 1/360 (6745 - Sqrt[45452065])

because they do not come out as Root objects. Then you observe for some numbers an inversion of sign in the coefficient list

In[82]:= RootApproximant[38.75996570032703, 100]
Out[82]= Root[-7 - 11 #1 - 11 #1^2 - 43 #1^3 + 55 #1^4 - 18 #1^5 + 
   2 #1^6 + 46 #1^7 - 24 #1^8 - 47 #1^9 + 13 #1^10 + 9 #1^11 - 
   39 #1^12 + #1^13 &, 3]

In[83]:= RootApproximant[1/38.75996570032703, 100]
Out[83]= Root[-1 + 39 #1 - 9 #1^2 - 13 #1^3 + 47 #1^4 + 24 #1^5 - 
   46 #1^6 - 2 #1^7 + 18 #1^8 - 55 #1^9 + 43 #1^10 + 11 #1^11 + 
   11 #1^12 + 7 #1^13 &, 3]

even if one defines modest and humble

Clear[mrbQ]
mrbQ[x_?NumericQ, d_Integer:100] := 
 Block[{a1 = CoefficientList[First[RootApproximant[x, d]][y], y], 
   a2 = CoefficientList[First[RootApproximant[1/x, d]][y], y]},
  (a1 == Reverse[a2]) || (a1 == -Reverse[a2])
  ]

the first few tests fail

In[88]:= l0 = RandomReal[{-19, 53}, 10]
Out[88]= {-5.56205, 18.565, 9.93291, 36.6722, 7.11272, -15.8707, \
48.0537, 2.31938, -17.7694, 20.6123}

In[90]:= mrbQ /@ l0
Out[90]= {True, True, True, True, True, False, True, True, True, True}

In[91]:= RootApproximant[-15.870657952807605, 100]
Out[91]= Root[-18 + 15 #1 - 2 #1^2 + 4 #1^3 - 15 #1^4 - 5 #1^5 + 
   8 #1^6 + 8 #1^7 + 21 #1^8 - 18 #1^9 + 18 #1^11 + 
   17 #1^12 + #1^13 &, 1]

In[92]:= RootApproximant[1/-15.870657952807605, 100]
Out[92]= Root[-2 - 33 #1 - 20 #1^2 - #1^3 - 9 #1^4 + 13 #1^5 - 
   10 #1^6 + 14 #1^7 + 19 #1^8 + 20 #1^9 &, 2]

this might be devoted to the statement in the RootApproximant manual page

Results from RootApproximant may not be unique.

Possibly the assumption (if proper stated) holds for numbers where RootApproximant gives for the number and it’s reciprocal number polynoms of the same degree.

3

Forget about it. Change the test a bit more (a PolynomialQ test is missing yet) and drop the degree condition

In[112]:= Clear[mrbQHumble]
mrbQHumble[x_?NumericQ] := 
 Block[{a1 = CoefficientList[First[RootApproximant[x]][y], y], 
   a2 = CoefficientList[First[RootApproximant[1/x]][y], y]},
  If[Length[a1] == Length[a2] && FreeQ[a1, y] && 
    FreeQ[a2, y], (a1 == Reverse[a2]) || (a1 == -Reverse[a2]), 
   Missing[]]
  ]

In[114]:= l0 = RandomReal[{-19, 53}, 100]
Out[114]= {-1.38507, 49.4481, 24.7934, 11.0104, 3.86794, 7.93207, \
48.0579, -9.44529, 48.7661, -14.129, -14.7824, -6.62547, 40.7146, \
-9.87912, -11.0193, 23.8705, -13.5526, 2.14101, 4.57075, -10.0782, \
-3.5094, -5.45227, 30.0554, 39.6618, 3.95229, 13.3368, 43.1726, \
25.5232, 4.30698, -9.89652, 25.0371, 44.8908, 31.7411, -10.7786, \
42.8577, 39.8379, -12.9649, -10.6592, -0.0523882, 24.5372, 52.9216, \
-12.2468, 27.3211, 25.072, -10.8939, 21.1145, -14.224, 52.6378, \
-12.6092, -4.91945, 52.327, 24.0178, 9.16044, 52.1168, 31.1463, \
16.357, 13.9551, 31.295, -8.99637, 43.5836, -14.6001, 34.3883, \
30.7991, 17.0297, -18.3356, -4.35444, 4.17391, 38.1627, 6.66596, \
28.9392, 51.549, -6.69014, 14.7294, -3.10411, 21.2488, 13.6281, \
5.75214, 1.00631, 44.6239, 22.1666, 39.5046, 47.7347, 26.2585, \
52.7089, 50.2851, 13.368, -5.99931, 31.8238, 5.17775, 24.6661, \
9.58021, 19.6149, 7.77517, -6.62582, 16.2579, 46.4658, 15.8527, \
52.8861, -8.88976, 10.9706}

In[115]:= And @@ DeleteMissing[mrbQHumble /@ l0]
During evaluation of In[115]:= First::normal: Nonatomic expression expected at position 1 in First[7335/7289]. >>
During evaluation of In[115]:= First::normal: Nonatomic expression expected at position 1 in First[7289/7335]. >>
Out[115]= False

and the wrong-doer is

In[118]:= RootApproximant[1/l0[[61]]]
Out[118]= Root[-7 - 102 #1 - 2 #1^2 - 72 #1^3 + 4 #1^4 + 65 #1^5 + 44 #1^6 &, 1]

In[119]:= RootApproximant[l0[[61]]]
Out[119]= Root[57 + 118 #1 - #1^2 + 139 #1^3 - 43 #1^4 + 11 #1^5 + #1^6 &, 1]

In[120]:= l0[[61]]
Out[120]= -14.6001
4

If p(x) ~~0 and is a polynomial of degree n, then q(x)= x^n*p(1/x) also is approximately 0 and now you have reversed the coeffs.

5

For an algebraic number x the property is obvious: Let a_0+a_1 x+a_2x^2+...+a_nx^n=0 be the \mathit{definition} of x. Divide by x^n \neq 0 to get a_0\left(\frac{1}{x}\right)^n+a_1 \left(\frac{1}{x}\right)^{n-1}+a_2 \left(\frac{1}{x}\right)^{n-2}+...+ a_n =0 wich has reversed coefficients for y=\frac{1}{x}. The accidential minus is possible because 0=-0. Only RootApproximant is the worst vehicle to show this.

Possibly one could stabilize RootApproximant by forcing it to hold this property because it is going to represent the input as algebraic number.

In[31]:= RootApproximant[SetPrecision[14.6001, #]] & /@ Range[18]
Out[31]= {15, 1/4 (29 + Sqrt[865]), 1/4 (29 + Sqrt[865]), 
 1/2 (15 + Sqrt[201]), 
 1/2 (15 + Sqrt[201]), 73/5, 73/5, 73/5, 73/5, 73/5, 
 Root[63 - 89 #1 - 38 #1^2 + 3 #1^3 &, 3], 
 Root[63 - 89 #1 - 38 #1^2 + 3 #1^3 &, 3], 
 Root[-23 + 37 #1 + 14 #1^2 - 3 #1^4 - 29 #1^5 + 2 #1^6 &, 4], 29171/1998, 
 Root[62 - 8 #1 - 82 #1^2 - 23 #1^3 + 37 #1^4 - 17 #1^5 + #1^6 &, 2], 
 Root[-71 + 44 #1 - 62 #1^2 - 3 #1^3 + 91 #1^4 - 50 #1^5 + 3 #1^6 &, 2], 146001/10000, 146001/10000}

In[32]:= RootApproximant[SetPrecision[1/14.6001, #]] & /@ Range[18]
Out[32]= {1/15, 1/6 (-29 + Sqrt[865]), 1/6 (-29 + Sqrt[865]), 
 1/12 (15 - Sqrt[201]), 
 1/12 (15 - Sqrt[201]), 5/73, 5/73, 5/73, 5/73, 5/73, 
 Root[3 - 38 #1 - 89 #1^2 + 63 #1^3 &, 2], 
 Root[3 - 38 #1 - 89 #1^2 + 63 #1^3 &, 2], 
 Root[-2 + 29 #1 + 3 #1^2 - 14 #1^4 - 37 #1^5 + 23 #1^6 &, 2], 1998/29171, 
 Root[1 - 17 #1 + 37 #1^2 - 23 #1^3 - 82 #1^4 - 8 #1^5 + 62 #1^6 &, 1], 
 Root[2 - 26 #1 - 47 #1^2 - 4 #1^3 + 115 #1^4 + 31 #1^5 + 58 #1^6 &, 1], 10000/146001, 10000/146001}