Group Abstract Group Abstract

Message Boards Message Boards

0
|
6.8K Views
|
4 Replies
|
5 Total Likes
View groups...
Share
Share this post:

Phenomenon in finding "simplest" algebraic numbers

4 Replies
POSTED BY: Daniel Lichtblau

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}
POSTED BY: Udo Krause

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.

POSTED BY: Udo Krause

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
POSTED BY: Udo Krause
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard