Descending Plane Partition

Author

Eric W. Weisstein
October 11, 2003

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

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

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

Code

This code doesn't quite work yet

DPPQ[l_List]:=Module[
{u,i,t=DroppedZeros[l]},
If[t==Reverse/@Sort/@t 
&&And@@LengthsQ/@t
&&And@@NoHolesQ/@l
&&And@@FlushQ/@Transpose[l]
&& And@@Table[DiagonalQ[l[[i]],i],{i,Length[l]}],
u=DroppedZeros[Transpose[l]];
(u==Reverse/@Union/@u),
False]
]

DroppedZeros[l_]:=Module[{i},
Table[Select[l[[i]],#≠0&],{i,Length[l]}]
]

NoHolesQ[l0_List]:=Module[{l=l0},
While[l≠{}&&l[[1]]==0,l=Drop[l,1]];
While[l≠{}&&l[[-1]]==0,l=Drop[l,-1]];
Position[l,0]=={}
]

DiagonalQ[l_,n_]:=(Union[l]=={0}||l[[n]]≠0);

FlushQ[l0_List]:=Module[{l=l0},
While[l≠{}&&l[[-1]]==0,l=Drop[l,-1]];
Position[l,0]=={}
]

LengthsQ[{}]:=True
LengthsQ[l_]:=(Length[l]<Max[l])

Enumeration

Order 2

dpp2=Flatten[Table[{{i,j}},
{i,2,1,-1},{j,2,0,-1}],1]

MatrixForm/@Select[dpp2,DPPQ[#]&]

Order 3

dpp3=Flatten[Table[{{i,j},{0,k}},
{i,3,2,-1},{j,3,0,-1},{k,2,0,-1}],2];

MatrixForm/@Select[dpp3,DPPQ[#]&]

Order 4

dpp4=Flatten[Table[{{i,j,k},{0,l,m},{0,0,n}},
{i,4,2,-1},{j,4,0,-1},{k,4,0,-1},{l,3,0,-1},{m,3,0,-1},{n,2,0,-1}],5];

Length[dpp4]

m=Select[dpp4,DPPQ[#]&];

MatrixForm/@m

Length[%]

There is one more of these than there ought to be