Lehmer's Mahler Measure Problem

Author

Eric W. Weisstein
April 15, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Calculus/LehmersMahlerMeasureProblem.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/LehmersMahlerMeasureProblem.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Code

RandomPolynomial[x_,n_,r_List]:=Nest[#x+Random[Integer,r]&,0,n+1]

MahlerMeasure[p_Integer,x_]:=0
NMahlerMeasure[p_Integer,x_]:=0

MahlerMeasure[p_,x_]:=Module[{roots=x/.{ToRules[Roots[p==0,x]]}},
Abs[Function[x,p][0]] Times@@(Max[Abs[#],1]&/@roots)
]

NMahlerMeasure[p_,x_]:=Module[{roots=x/.{ToRules[NRoots[p==0,x]]}},
Abs[Function[x,p][0]] Times@@(Max[Abs[#],1]&/@roots)
]

NMahlerMeasure2[p_,x_]:=Exp[NIntegrate[Log[Abs[p/.x->Exp[2Pi I t]]],{t,0,1}]]

Graphic

lehmer[x_]:=1+x-(x^3)-(x^4)-(x^5)-(x^6)-(x^7)+(x^9)+(x^10)

Expand[CoefsToPoly[halfpoly[{1,1,0,-1,-1,-1}],x]]

halfpoly[c_List]:=Join[c,Rest[Reverse[c]]]
CoefsToPoly[c_List,x_]:=Expand[Fold[x #1+#2&,0,Reverse[c]]]

l={{1,1,0,-1,-1,-1},{1,1,1,1,0,0,-1,-1,-1,-1},{1,0,0,1,-1,0,0,-1}};

NMahlerMeasure[#,x]&/@(CoefsToPoly[halfpoly[#],x]&/@l)

{#,CoefsToPoly[#,x]}&@halfpoly[l[[1]]]

{Exponent[poly=CoefsToPoly[halfpoly[#],x],x],Count[Flatten[RootReduce[Abs[x]/.{ToRules[Roots[poly==0,x]]}]],1,1]}&/@l

CirclePlot[c_List,{x_,y_}]:=Graphics[{PointSize[.06],Point[{Re[#],Im[#]}]&/@(x/.{ToRules[NRoots[(p=CoefsToPoly[halfpoly[c],x])==0,x]]})},AspectRatio->Automatic,Axes->True,
Epilog->{Text[TraditionalForm[c],{0,-1.3}],
Text[TraditionalForm["\!\(TraditionalForm\`\*SubscriptBox[\(M\), \(1\)] \\\\  \\\\  \\\\\\\\ \((P)\)\)="<>ToString[NMahlerMeasure[p,x]]],{0,-1.55}]},
AxesLabel->TraditionalForm/@{x,y},
Prolog->{{RGBColor[1,0,0],Circle[{0,0},1]}},PlotRange->All]

Show[GraphicsArray[CirclePlot[#,{x,y}]&/@l],GraphicsSpacing->-.1]

Smyth Bound

NRoots[x^3-x-1==0,x]

Cyclotomic Polynomials

MahlerMeasure[#,x]&/@Times@@Map[Cyclotomic[#,x]&,Table[Random[Integer,{1,10}],{2},{25}],{2}]

MahlerMeasure[#,x]&/@Times@@Map[Cyclotomic[#,x]&,Table[Random[Integer,{1,20}],{Random[Integer,{1,5}]},{50}],{2}]

Mahler Measure of Lehmer's Polynomial

{#,N[#]}&@(m=MahlerMeasure[lehmer[x],x])

NRoots[First[m][x]==0,x]

TableForm[Table[MahlerMeasure[a x+b,x],{a,-5,5},{b,-5,5}]]

n=1000;
ContourPlot[MahlerMeasure[a x+b,x],{a,-n,n},{b,-n,n},ContourLines->False,ColorFunction->Hue]

d=Table[RandomPolynomial[x,Random[Integer,{1,10}],{-1,1}],{100000}];//Timing

m=NMahlerMeasure[#,x]&/@d;//Timing

(Flatten@Position[m,_?(Abs[#]>0.0001&&Abs[#-1]>.0001&&#<1.1762&)])

Through[{Min,Max}[Select[m,Abs[#]>0.0001&&Abs[#-1]>.0001&]]]

barLabels[x0_,x1_,{dx_,ddx_}]:=Module[{i},
Flatten[Table[{ToString[i],Table["",{dx/ddx-1}]},{i,x0,x1,dx}]]
]

BarChart[BinCounts[m,{1,3,.05}],PlotRange->All,BarSpacing->0,BarLabels->barLabels[1,3,{.2,.05}]]