Plane Partition

Author

Eric W. Weisstein
December 2, 2008

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Combinatorics/PlanePartition.nb.

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

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

Additional Authors

Generation code by Wouter Meeussen
http://users.pandora.be/Wouter.Meeussen/PlanePartitions.txt
December 28, 2003

Code

coversQ[parent_,child_]:=And[Length[parent]>=Length[child],Min[Take[parent,Length@child]-child]>=0]

planepartitionQ[par_]:=MatchQ[par,{{___Integer}..}]&&If[Length[par]>1,And@@MapThread[coversQ,{Drop[par,-1],Rest[par]}],True]

PlanePartitions[n_Integer]:=Module[{l1,l2,l3,l4,z,w},
l1=z@@@IntegerPartitions[n];
l2=l1/.k_Integer/;(k>1):>w@@IntegerPartitions[k];
l3=l2/.z[x_w,y:(1...)]:>Thread[z[x,y],w]/.
z[x__w]:>Outer[z,x]/.z[x__w,y:(1...)]:>Outer[z,x,Sequence@@({y}/. 1->w[1])]/.w->Sequence;
l4=l3/.z[x___List,y:(1..)]:>z[x,Sequence@@Transpose[{{y}}]]/.z->List;Cases[Union[l4],_?planepartitionQ]
]

3-D Diagram

PlanePartitionDiagram[l_List]:=Module[{i,j,k},
Graphics3D[
Table[Cuboid[{j,-i,k}],
{i,Length[l]},
{j,Length[l[[i]]]},
{k,l[[i,j]]}
]
]
]

Show[PlanePartitionDiagram[{{5,4,2,1,1},{3,2},{2,2}}]]

Enumeration

A000219

Length/@PlanePartitions/@Range[20]//Timing

PlanePartitions[2]

(ColumnForm/@PlanePartitions[#]&)/@Range[4]//ColumnForm

Generating Function

Product[(((1-(x^k)))^k),{k,∞}]

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

seq=CoefficientList[Series[1/Product[(((1-(x^k)))^k),{k,100}],{x,0,20}],x]

FindLinearRecurrence[Drop[seq,2]]//Head//Timing

FindSequenceFunction[seq,n]//Head//Timing

FindGeneratingFunction[seq,x]//Head//Timing

Recurrence

a[0]:=1
a[n_]:=a[n]=(1/n)Sum[a[n-k]DivisorSigma[2,k],{k,n}]

Array[a,20]

RSolve[{(1/n)Sum[a[n-k]DivisorSigma[2,k],{k,n}],a[0]==1},a[n],n]

RecurrenceTable[{(1/n)Sum[a[n-k]DivisorSigma[2,k],{k,n}],a[0]==1},a,{n,5}]

Series[Exp[Sum[DivisorSigma[2,n]((x^n)/n),{n,10}]],{x,0,10}]

Sum[DivisorSigma[2,n]((x^n)/n),{n,∞}]

CoefficientList[Series[Exp[Sum[DivisorSigma[2,n]((x^n)/n),{n,20}]],{x,0,20}],x]

Asymptotic

Limit[Zeta[3]^(7/36)/2^(11/36)/Sqrt[3*Pi]/Glaisher*E^(3*Zeta[3]^(1/3)*(n/2)^(2/3)+1/12)/n^(25/36)/a[n],n->Infinity]==1

seq=CoefficientList[Series[1/Product[(((1-(x^k)))^k),{k,100}],{x,0,30}],x]

ListPlot[{seq,
Table[Zeta[3]^(7/36)/2^(11/36)/Sqrt[3*Pi]/Glaisher*E^(3*Zeta[3]^(1/3)*(n/2)^(2/3)+1/12)/n^(25/36),{n,30}]}]

Length[seq]

ListPlot[Rest@seq-
Table[Zeta[3]^(7/36)/2^(11/36)/Sqrt[3*Pi]/Glaisher*E^(3*Zeta[3]^(1/3)*(n/2)^(2/3)+1/12)/n^(25/36),{n,30}]]

Young Diagrams fit in an a×b×c Box

BoxPartitions[a_,b_,c_]:=
Product[(i+j+k-1)/(i+j+k-2),{i,a},{j,b},{k,c}]

FullSimplify[(∏_(k=1)^c)((-1+i+j+k)/(-2+i+j+k))]

FullSimplify[(∏_(j=1)^b)(1+(c/(-1+i+j)))]

FunctionExpand[%]

(∏_(i=1)^a)((Gamma[i] Gamma[b+c+i])/(Gamma[b+i] Gamma[c+i]))

V6

BoxPartitions[a,b,c]

V7

BoxPartitions[a,b,c]

FullSimplify[BoxPartitions[a,b,c]-((BarnesG[a+1]BarnesG[b+1]BarnesG[c+1]BarnesG[a+b+c+1])/(BarnesG[a+b+1]BarnesG[a+c+1]BarnesG[b+c+1]))]

Table[%/.{a->RandomInteger[{1,10}],b->RandomInteger[{1,10}],c->RandomInteger[{1,10}]},{100}]//Union

(∏_(i=1)^a)((Gamma[i] Gamma[b+c+i])/(Gamma[b+i] Gamma[c+i]))

FullSimplify[BoxPartitions[n,n,n],n∈Integers&&n>0]

Table[((((BarnesG[1+n])^(3-2 n)) ((BarnesG[2+n])^(2 n)) BarnesG[1+3 n] ((Gamma[1+n])^(-2 n)))/((BarnesG[1+2 n])^3)),{n,10}]

In terms of Barnes G

BarnesG[n_Integer]:=Times@@(Factorial/@Range[n-2])

bbb[a_,b_,c_]:=g[a+1]g[b+c+a+1]/g[b+c+1]/(g[b+a+1]/g[b+1]g[c+a+1]/g[c+1])/.g->BarnesG

bbb[a,b,c]

Table[Subtract@@{bbb[a,b,c],(∏_(i=1)^a)((Gamma[i] Gamma[b+c+i])/(Gamma[b+i] Gamma[c+i])) }/. Thread[{a,b,c}->Table[Random[Integer,{1,10}],{3}]],{5}]

With a=b=c=n

bbb[n,n,n]

Product[((Gamma[i]Gamma[i+2n])/(Gamma[i+n]^2)),{i,n}]

Table[bbb[n,n,n],{n,10}]