Pisot Number

Author

Eric W. Weisstein
May 4, 2006

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Constants/PisotNumber.nb.

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

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

Code

<<NumberTheory`AlgebraicNumberFields`

PisotQ[x_?(Element[#,Algebraics]&)]:=Module[{y},
x>1&&And@@((Abs[#]<1)&/@Select[ List@@Last/@Roots[MinimalPolynomial[x,y]==0,y,Cubics->False,Quartics->False],#≠x&])
]

Pisot Numbers

(Subscript[θ, 0])

PisotQ[GoldenRatio]

(Subscript[θ, 1])

(Subscript[θ, 1])=RootReduce[2^(1/3)/(27+3 Sqrt[69])^(1/3)+(27+3 Sqrt[69])^(1/3)/(3 2^(1/3))]

N[(Subscript[θ, 1]),20]

PisotQ[(Subscript[θ, 1])]

(Subscript[θ, 2])

(Subscript[θ, 2])=Select[List@@(Last/@Roots[x^4-x^3-1==0,x,Quartics->False]),Positive][[1]]

N[(Subscript[θ, 2]),20]

PisotQ[(Subscript[θ, 2])]

Others

Polynomial[l_List, x_] := Fold[x #1 + #2 &, 0, l]

θ16p=Expand[Polynomial[{1,-2,2,-3,2,-2,1,0,0,1,-1,2,-2,2,-2,1,-1},x]]

θ16=Select[List@@(Last/@Roots[θ16p==0,x]),Positive][[1]]

N[θ16,20]

θ20p=Expand[Polynomial[{1,-2,0,1,-1,0,1,-1,0,1,0,-1,0,1,-1,0,1,-1,0,1,-1},x]]

θ20=Select[List@@(Last/@Roots[θ20p==0,x]),Positive][[1]]

N[θ20,20]

Examples

Trott I (2004)

((((((3 (Sqrt[69])+27)^(1/3))/(3 (2^(1/3))))+((2^(1/3))/((3 (Sqrt[69])+27)^(1/3)))))^27369)

RootReduce[(((3 (Sqrt[69])+27)^(1/3))/(3 (2^(1/3))))+((2^(1/3))/((3 (Sqrt[69])+27)^(1/3)))]

Block[{$MaxExtraPrecision=6000},
N[FractionalPart[(2^(1/3)/(27+3 Sqrt[69])^(1/3)+(27+3 Sqrt[69])^(1/3)/(3 2^(1/3)))^27369],10]
]

PisotQ[((((((3 (Sqrt[69])+27)^(1/3))/(3 (2^(1/3))))+((2^(1/3))/((3 (Sqrt[69])+27)^(1/3)))))^27369)]

Sofroniou

((((1/3) (((1/2) (3 (Sqrt[69])+27))^(1/3))+((2/(3 (Sqrt[69])+27))^(1/3))))^30000)

cf=Block[{$MaxExtraPrecision=Infinity},
ContinuedFraction[((2/(27 + 3*Sqrt[69]))^(1/3) +
((27 + 3*Sqrt[69])/2)^(1/3)/3)^30000,10]];//Timing

cf//N

PisotQ[((((1/3) (((1/2) (3 (Sqrt[69])+27))^(1/3))+((2/(3 (Sqrt[69])+27))^(1/3))))^30000)]

Powers of (Subscript[θ, 1])

ListPlot[Table[N[(Subscript[θ, 1])^n-Floor[(Subscript[θ, 1])^n],1000],{n,1,100}],
PlotStyle->{Red,PointSize[.02]},
AxesLabel->TraditionalForm/@{n,HoldForm[(Subscript[θ, 1])^n-Floor[(Subscript[θ, 1])^n]]}
]

Numbers Closer to 0

Position[Table[N[r^n-Floor[r^n],2000],{n,1,200}],_?(#<1/2&)]//Flatten

Numbers Closer to 1

Position[Table[N[r^n-Floor[r^n],2000],{n,1,200}],_?(#>1/2&)]//Flatten

Olivier

Show[Graphics[{PointSize[.007],{{Hue[0],Point/@(Rest/@(First@#))},{Hue[3/5],Point/@(Rest/@(Last@#))}}&@Split[Sort[Table[If[Abs[#]<1/2,{1,i,-1/i Log@#},{2,i,-1/i Log@(1-#)}]&@FractionalPart[N[Root[z^3-z-1,1]^i,200]],{i,1,500}]],First[#1]==First[#2]&]}],PlotRange->{1/10,1/5},Axes->True]