Equidistributed Sequence

Author

Eric W. Weisstein
November 24, 2003

This notebook downloaded from http://mathworld.wolfram.com/notebooks/NumberTheory/EquidistributedSequence.nb.

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

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

Code

IntervalPlot[r_,{a_,b_},op_:Times]:=Module[{i,j,h=.15,dy=.2},Graphics[{Table[Line[{{0,-i dy},{1,-i dy}}],{i,a,b}],Table[Line[{{j/i,-(i+h)dy},{j/i,(-i+h)dy}}],{i,a,b},{j,0,i}],{Red,PointSize[.03],Table[Point[{FractionalPart[op[r,i]],-j dy}],{j,a,b},{i,j}]},
Text[TraditionalForm[r],{.5,0}],
Table[Text[TraditionalForm[frac[op[r,i]]],{-.02,-i dy},{1,0}],{i,a,b}],Table[Text[FractionalPart[op[r,i]//N],{1.05,-i dy},{-1,0}],{i,a,b}]},
PlotRange->All]
]

IntervalPlot[r_,n_]:=IntervalPlot[r,{1,n}]

IntervalPlot[r_]:=IntervalPlot[r,10]

IntervalPlot::usage="IntervalPlot[r,{a,b},op] plots FractionalPart[op[i,r]] for i = a, ..., b. The default op is Times, but could be Power, etc."

Plots of distributes of iterates

<<Statistics`DataManipulation`
<<Utilities`Typesetting`

labels=Flatten[Table[{ToString[i],"","","","","","","","",""},{i,0,1,.25}]]

Show[GraphicsArray[
Block[{$DisplayFunction=Identity},
BarChart[BinCounts[
Table[FractionalPart[Log[n]//N],{n,#}],{0,1,.025}],
PlotRange->All,BarSpacing->0,BarLabels->labels,
PlotLabel->TraditionalForm[FractionalPart[Log[n]]]
]&/@{5000,10^4}]
]]//Timing

Show[GraphicsArray[Partition[BarChart[BinCounts[
Table[FractionalPart[# n]//N,{n,10000}],{0,1,.05}],
PlotRange->All,BarSpacing->0,BarLabels->labels,
PlotRange->{0,510},
DisplayFunction->Identity,PlotLabel->TraditionalForm[#]]&/@{E,EulerGamma,GoldenRatio,Pi},2],GraphicsSpacing->{-.05,.1}]]//Timing

BarChart[BinCounts[
Table[FractionalPart[# n]//N,{n,100000}],{0,1,.05}],
PlotRange->All,BarSpacing->0,BarLabels->labels,
PlotLabel->TraditionalForm[#]]&[Pi]//Timing

Plots of positions of iterates

Show[GraphicsArray[Partition[IntervalPlot/@{E,EulerGamma,GoldenRatio,Pi},2]],
GraphicsSpacing->{.1,-.2}]

Powers

E

Golden Ratio

N[Table[N[FractionalPart[GoldenRatio^n],100],{n,100}]]

BarChart[BinCounts[
Table[N[FractionalPart[GoldenRatio^n],20],{n,2000}],{0,1,.05}],
PlotRange->All,BarSpacing->0,BarLabels->labels,
PlotLabel->TraditionalForm[GoldenRatio]]

Pi

BarChart[BinCounts[
Table[N[FractionalPart[Pi^n],20],{n,2000}],{0,1,.05}],
PlotRange->All,BarSpacing->0,BarLabels->labels,PlotLabel->TraditionalForm[Pi]]

(Sqrt[2])+1

N[Table[N[FractionalPart[(1+Sqrt[2])^n],100],{n,100}]]

BarChart[BinCounts[
Table[N[FractionalPart[(1+Sqrt[2])^n],20],{n,2000}],{0,1,.05}],
PlotRange->All,BarSpacing->0,BarLabels->labels,
PlotLabel->TraditionalForm[(1+Sqrt[2])]]

Counts of Elements in Intervals

FractionalPartDistribution[c_,div_]:=Module[{i},
MyBinCounts[
Table[FractionalPart[c i],{i,0,div}],{0,1,1/div}]
]

MyBinCounts[l_,{x0_,x1_,dx_}]:=Module[{s=(Sort[l]-x0)/dx/(x1-x0),i,n=(x1-x0)/dx},
Table[Count[s,_?(i-1<#<i&)],{i,n}]
]

Table[FractionalPartDistribution[E,n],{n,15}]//ColumnForm

Table[FractionalPart[E i],{n,4},{i,n}]//N//ColumnForm

Count[#,0]&/@(FractionalPartDistribution[E,#]&/@Range[10])

Position[FractionalPartDistribution[E,#]&/@Range[100],_?(FreeQ[#,0]&),1,Heads->False]//Flatten//Timing

Values of n with no bins blank

<<MathWorld`Graphs`
<<MathWorld`IntegerSequence`

constants={{"A036413",E},{"A046158",EulerGamma},{"A036415",GoldenRatio},{"A036417",Pi}};

grid[data_]:=TextGrid[{#[[2]],Hyperlink[#[[1]],"https://oeis.org/"<>#[[1]]],Take[#2,2],Max@BFileSequence[FromDigits[StringDrop[#[[1]],1]]],Row[#2[[3]],","]}&@@@Transpose[{constants,data}],Dividers->All,Alignment->{{{Left},Decimal,Left}}]

(10^3)

data=AbsoluteTiming[Sequence@@Timing[EquidistributedSubdivisions[#2,10^3]]]&@@@constants

grid[data]

(10^4)

data=AbsoluteTiming[Sequence@@Timing[EquidistributedSubdivisions[#2,10^4]]]&@@@constants

grid[data]

(10^5)

data=AbsoluteTiming[Sequence@@Timing[EquidistributedSubdivisions[#2,10^5]]]&@@@constants

grid[data]

2*^5

data=AbsoluteTiming[Sequence@@Timing[EquidistributedSubdivisions[#2,2*^5]]]&@@@constants

grid[data]

5*^5

data=AbsoluteTiming[Sequence@@Timing[EquidistributedSubdivisions[#2,5*^5]]]&@@@constants

grid[data]

(10^6)

data=AbsoluteTiming[Sequence@@Timing[EquidistributedSubdivisions[#2,1*^6]]]&@@@constants

grid[data]

Slow algorithms

Procedural (slow)

Modified from code in A036415:

NoBlankBinsSlow[nmax_]:=Module[{
a={},b,m={}
},
Do[AppendTo[a,N[n GoldenRatio-Floor[n GoldenRatio],50]];a=Sort[a];b={0};Do[AppendTo[b,k/n],{k,n}];b=Sort[b];c=0;Do[If[c===0&&(a[[k]]<b[[k+1]])&&(a[[k]]>b[[k]]),Null,c=1],{k,Length[a]}];If[c==0,AppendTo[m,n]],{n,nmax}];
m
]

NoBlankBinsSlow[10^3]//Timing

NoBlankBinsSlow[10^4]//Timing

Less + Table

FullBinsQ[f0_]:=Module[
{
n=Length[f0],int,f=Sort[f0]
},
int=Table[{(i-1)/n,f[[i]],i/n},{i,n}];
AllTrue[int,Less@@#&]
]

NoBlankBins[nmax_]:=Module[
{
f=FractionalPart[N[GoldenRatio Range[nmax]]]
},
Position[Table[FullBinsQ[Take[f,n]],{n,nmax}],True,1,Heads->False]//Flatten
]

NoBlankBins[10^3]//Timing//AbsoluteTiming

NoBlankBins[10^4]//Timing//AbsoluteTiming

NoBlankBins[10^5]//Timing//AbsoluteTiming

NoBlankBins[10^6]//Timing

Less + Partition (fastest AbsoluteTiming)

FullBinsQ[f_]:=Module[
{n=Length[f],int,part},
part=Partition[Subdivide[0.,1,n],2,1];
int=Transpose[{part[[All,1]],Sort[f],part[[All,2]]}];
AllTrue[int,Less@@#&]
]

NoBlankBins[nmax_]:=Module[
{f=FractionalPart[N[GoldenRatio Range[nmax]]]},
Flatten@Position[Table[FullBinsQ[Take[f,n]],{n,nmax}],True]
]

NoBlankBins[10^3]//Timing//AbsoluteTiming

NoBlankBins[10^4]//Timing//AbsoluteTiming

NoBlankBins[10^5]//Timing//AbsoluteTiming

NoBlankBins[10^6]//Timing

BinCounts (fastest timing)

NoBlankBinsBinCounts[nmax_]:=Module[{f=FractionalPart[N[GoldenRatio Range[nmax]]]},
Position[Table[AllTrue[BinCounts[Take[f,n],{0,1,1/n}],Positive],{n,nmax}],True]//Flatten
]

NoBlankBinsBinCounts[(10^4)]//Timing//AbsoluteTiming

NoBlankBinsBinCounts[10^5]//Timing//AbsoluteTiming

NoBlankBinsBinCounts[10^6]//Timing

...ran overnight...

N[..., 20] BinCounts

f=FractionalPart[N[GoldenRatio Range[10^4],20]];
Position[Table[BinCounts[Take[f,n],{0,1,1/n}],{n,10^4}],_?(FreeQ[#,0]&),1,Heads->False]//Flatten//Timing

Position[NoneTrue[#,Function[s,s==0]]&/@Table[BinCounts[Take[f,n],{0,1,1/n}],{n,10^4}],True]//Flatten//Timing

f=FractionalPart[N[GoldenRatio Range[10^5],20]];
Position[MapIndexed[BinCounts[#,{0,1,1/#2[[1]]}]&,Reverse@NestList[Most,f,Length[f]-1]],_?(FreeQ[#,0]&),1,Heads->False]//Flatten//Timing