Hard Hexagon Entropy Constant

Author

Eric W. Weisstein
August 13, 2008

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

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

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

Numerical Value

N[ExactConstant["hard hexagon entropy constant"],20]

Series

f and f2 do not agree, but should according to Baxter (1982), p. 408

V6

G[x_,nn_:Infinity]:=Product[(1/((1-(x^(5n-4)))(1-(x^(5n-1))))),{n,nn}]
H[x_,nn_:Infinity]:=Product[(1/((1-(x^(5n-3)))(1-(x^(5n-2))))),{n,nn}]

Series[G[x,100],{x,0,10}]

f[x_,k_]:=((((H[x,k])^3)((QSeries[{(x^5)},k])^2))/((G[x,k])^2))Product[(((1-(x^(6n-4)))(((1-(x^(6n-3))))^2)(1-(x^(6n-2))))/((1-(x^(6n-5)))(1-(x^(6n-1)))(((1-(x^(6n))))^2))),{n,k}]

Series[f[x,200],{x,0,10}]

CoefficientList[%,x]

f[.999,1000]

f2[x_,k_]:=((((G[x,k])^3)((QSeries[{(x^5)},k])^2))/((H[x,k])^2))Product[(((1-(x^(3n-2)))(1-(x^(3n-1))))/(((1-(x^(3n))))^2)),{n,k}]

Series[f2[x,200],{x,0,10}]

CoefficientList[%,x]

f2[.999,1000]

V7

G[x_]:=Product[(1/((1-(x^(5n-4)))(1-(x^(5n-1))))),{n,∞}]
H[x_]:=Product[(1/((1-(x^(5n-3)))(1-(x^(5n-2))))),{n,∞}]
f[x_]:=((((H[x])^3)((QPochhammer[(x^5)])^2))/((G[x])^2))Product[(((1-(x^(6n-4)))(((1-(x^(6n-3))))^2)(1-(x^(6n-2))))/((1-(x^(6n-5)))(1-(x^(6n-1)))(((1-(x^(6n))))^2))),{n,∞}]
f2[x_]:=((((G[x])^3)((QPochhammer[(x^5)])^2))/((H[x])^2))Product[(((1-(x^(3n-2)))(1-(x^(3n-1))))/(((1-(x^(3n))))^2)),{n,∞}]

G[x]//FullSimplify

Series[G[x],{x,0,10}]

H[x]//FullSimplify

Series[H[x],{x,0,10}]

f[x]

Series[%41,{x,0,5}]

f2[x]

Series[%,{x,0,5}]

Limit

Product[(1/((1-(x^(5n-4)))(1-(x^(5n-1))))),{n,∞}]

FullSimplify[%]==%

((((((1-(1/(x^4))) (-1+x))/(x QPochhammer[(1/(x^4)),(x^5)] QPochhammer[(1/x),(x^5)]))))^(1/x^2))/.x->999.

((Product[(1/((1-(x^(5n-4)))(1-(x^(5n-1))))),{n,20}])^(1/(x^2)))/.x->99999.

Limit[((((((1-(1/(x^4))) (-1+x))/(x QPochhammer[(1/(x^4)),(x^5)] QPochhammer[(1/x),(x^5)]))))^(1/x^2)),x->∞]

Kings

NoAdjacentOnes[n_]:=Module[{i,j,t,s,adj,pos,tf},
t=Table[{j+Floor[i/2],i},{i,n},{j,n}];
s=Subsets[Flatten[t,1],{2}];
adj=s[[Flatten[Position[-Subtract@@@s,{1,0}|{0,1}|{1,1},{1}]]]];
pos=adj/.Dispatch[Thread[Thread[Flatten[t,1]->Flatten[Table[{i,j},{i,n},{j,n}],1]]]];
tf=Function[m,!MemberQ[Extract[m,#]&/@pos,{1,1}]]/@Matrices[n];
Pick[Matrices[n],tf]
]

OnesDisplay[m_]:=Module[{t,n=Length[m]},
t=Table["",{2n},{n}];
Do[t[[2j-1+Mod[i-1,2],i]]=m[[i,j]],{i,n},{j,n}];
t
]

MatrixForm/@OnesDisplay/@NoAdjacentOnes[2]

MatrixForm/@OnesDisplay/@NoAdjacentOnes[3]

Length/@NoAdjacentOnes/@Range[4]//Timing

Length/@NoAdjacentOnes/@Range[5]//Timing

r=N[MapIndexed[#1^(1/#2[[1]]^2)&,{2,6,43,557,14432,719469,70372090,13351521479,4941545691252,3559349503024593,4993739972681894885,13642580224488264353504}],200];

<<Utilities`Plot`

ListPlot[r,PlotRange->All,Joined->True,PlotStyle->Red,AxesOrigin->{1,1.3}]

SequenceLimit[Drop[r,2]]

Guess

$Version

FindLinearRecurrence[{2,6,43,557,14432,719469,70372090,13351521479,4941545691252}]

FindGeneratingFunction[{2,6,43,557,14432,719469,70372090,13351521479,4941545691252},x]

FindSequenceFunction[{2,6,43,557,14432,719469,70372090,13351521479,4941545691252},x]

Algebraic Expression

a=-124/363 11^(1/3);
b=2501/11979 33^(1/2);
c=(1/4+3/8 a((b+1)^(1/3)-(b-1)^(1/3)))^(1/3);

κ[1]:=1/4 3^(5/4) 11^(-5/12) c^(-2)
κ[2]:=(1-Sqrt[1-c]+Sqrt[2+c+2Sqrt[1+c+c^2]])^2
κ[3]:=(-1-Sqrt[1-c]+Sqrt[2+c+2Sqrt[1+c+c^2]])^2
κ[4]:=(Sqrt[1-a]+Sqrt[2+a+2Sqrt[1+a+a^2]])^(-1/2)
κ=Times@@Array[κ,4];

TraditionalForm[c1=(1/4-31(13t+81)/(242(32t+7)))^(1/3)]

TraditionalForm[c2=(1/4-31(32t^2-39t-19)/(2*11^3))^(1/3)]

{c,c1,c2}/.t->Root[#^3-#^2-#-1&,1]//N

RootReduce[c]//TraditionalForm

Numerical

N[κ,20]

Using RootReduce

RootReduce[κ]//Timing

By Numericization and LLL Recognition

<<Utilities`Simplify`

ToExact[κ,24,1500,2000]//Timing

As an Algebraic Number

poly=25937424601z^24+2013290651222784z^22+2505062311720673792z^20+797726698866658379776z^18+7449488310131083100160z^16+2958015038376958230528z^14-72405670285649161617408z^12+107155448150443388043264z^10-71220809441400405884928z^8-73347491183630103871488z^6+97143135277377575190528z^4-32751691810479015985152;

RootReduce[Select[Last/@Roots[poly==0,z],Positive]]

N[%-κ,5000]