Stolarsky-Harborth Constant

Author

Eric W. Weisstein
February 2, 2015

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Constants/Stolarsky-HarborthConstant.nb.

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

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

Initialization

θ=Log2[3];

DigitCount[n,2,1]

Table[DigitCount[n,2,1],{n,20}]

a[0]:=0
a[n_?EvenQ]:=a[n]=a[n/2]
a[n_?OddQ]:=a[n]=a[(n-1)/2]+1

Table[a[n],{n,20}]

Number of odd binomial coefficients in the first n rows of Pascal's triangle

(∑_(k=0)^(n-1))(2^(DigitCount[k,2,1]))

f[n_]:=Sum[2^DigitCount[k,2,1],{k,0,n-1}]

f[n]

Table[f[n],{n,20}]

(∑_(j=0)^n)(∑_(k=0)^j)(Mod[(Binomial[j, k]), 2])

Table[Sum[Mod[Binomial[j, k], 2], {j, 0, n}, {k, 0, j}], {n, 0, 20}]

G.F.:(x/(1-x)) (∏_(k=0)^∞)(2 (x^(2^k))+1)

Product[1+2x^2^k,{k,0,∞}]

Product[1+2x^2^k,{k,0,n}]

Series[(x/(1-x))Product[1+2x^2^k,{k,0,10}],{x,0,20}]

Recurrence

b[0]:=0
b[1]:=1
b[n_?EvenQ]:=b[n]=3b[n/2]
b[n_?OddQ]:=b[n]=2b[(n-1)/2]+b[(n+1)/2]

Table[b[n],{n,20}]

f((2^k))

Table[f[2^k],{k,10}]

Plots

<<Utilities`Typesetting`

pts=10000;
data=Table[b[n],{n,pts}];
data2=data/Table[(n^θ),{n,pts}];

GraphicsGrid[{{
ListPlot[data,
AxesLabel->{n,(Subscript[f, n])},
Joined->True,PlotRange->All,PlotStyle->Red],
ListPlot[data2,
AxesLabel->{n,InlineFraction[(Subscript[f, n]),HoldForm[(n^θ)]]},
Joined->True,PlotRange->All,PlotStyle->Red]
}},ImageSize->500]

Sum of Odd Elements

odd[n_]:=Count[Flatten[Table[Binomial[n,k],{k,0,n}]],_?OddQ]

sums=Rest[FoldList[Plus,0,Table[odd[n],{n,0,33}]]]

l=MapIndexed[#1 (Sequence@@#2)^(-Log[3]/Log[2])&,sums]

N[l]

Position[l,_?(FullSimplify[Log[#]]==0&),{1}]//Flatten

θ=SetPrecision[Log[2,3],20];
sums=Rest[FoldList[Plus,0,Table[odd[n],{n,0,700}]]];
l=MapIndexed[#1 (Sequence@@#2)^(-θ)&,sums];

Split[FoldList[Min,1,N[l,20]]]

mins=Length/@Split[FoldList[Min,1,N[l,30]]]

ListPlot[l,PlotJoined->True]

pos=Drop[Rest[FoldList[Plus,0,mins]],-1]

Constant Value

Method 1

Sum[Mod[Binomial[k,j],2],{k,n},{j,0,k}]

Sum[Mod[Binomial[k,j],2],{j,0,k}]

NMinValue[{Sum[2^DigitCount[k,2,1],{k,0,n-1}],Element[n,Integers]&&n≥0},n]

MinValue[{Sum[Mod[Binomial[k,j],2],{k,n},{j,0,k}]/(n^(Log2[3])),Element[n,Integers]&&n≥0},n]

Limit[n^-Log[2,3] (∑_(j=0)^n)(∑_(k=0)^j)Mod[Binomial[j,k],2],n->∞]

ListPlot[Table[N[(n^(-Log2[3])) (∑_(j=0)^n)(∑_(k=0)^j)Mod[Binomial[j,k],2]],{n,200}],Joined->True]

Table[N[(n^(-Log2[3])) (∑_(j=0)^n)(∑_(k=0)^j)Mod[Binomial[j,k],2],20],{n,200}]//Min//Timing

Timing[Min[Table[N[Sum[Mod[Binomial[j, k], 2], {j, 0, n}, {k, 0, j}]/n^Log2[3], 20], {n, 300}]]]

Table[N[(n^(-Log2[3])) Sum[(2^(DigitCount[k,2,1])),{k,0,n-1}],20],{n,300}]//Min//Timing

Table[N[(n^(-Log2[3])) Sum[(2^(DigitCount[k,2,1])),{k,0,n-1}],20],{n,500}]//Min//Timing

Method 2

Take[Sort[N[data2,20]],10]

This possibly misses points where -/+ are both local minima.

n[0]:=1
n[r_]:=n[r]=(c=2n[r-1])+If[Less@@(b[c+#]/(((c+#))^θ)&/@{-1,1}),-1,1]
q[r_]:=b[n[r]]/((n[r])^θ)

nr=Table[n[r],{r,0,30}]

nr={1,3,5,11,21,43,87,173,347,693,1387,2775,5549,11099,22197,44395,88789,177579,355159,710317,1420635,2841269,5682539,11365079,22730157,45460315,90920629,181841259,363682519,727365037,1454730075};

nr2=If[b[#[[2]]-2]/(((#[[2]]-2))^θ)<b[#[[1]]]/((#[[1]])^θ),#[[2]]-2,{}]&/@Partition[Rest[nr],2,1]

newnr=Sort[Flatten[{nr,nr2}]]

pts=200;
data=Table[b[n],{n,pts}];
data2=data/Table[(n^θ),{n,pts}];

ListPlot[data2,
AxesLabel->{n,InlineFraction[(Subscript[f, n]),HoldForm[(n^θ)]]},
Joined->True,PlotRange->All,PlotStyle->Red,
Epilog->{Blue,PointSize[.025],Point/@Table[{n[r],b[n[r]]/((n[r])^θ)},{r,0,30}]}]

fr=b/@nr

DigitCount[#,2,1]&/@nr

qs=Table[q[r],{r,40}];

ListPlot[Table[q[r],{r,100}],PlotJoined->True]

$MaxExtraPrecision=200;

β=N[q[400],120]

SequenceLimit[N[Table[q[r],{r,300,400}],300]]

ListPlot[N[Log10[Abs[Table[q[r]-q[400],{r,399}]]],22],Joined->True,PlotRange->All]