solid partitions generator

Question

According to Wikipedia, a solid partition of $n$ is a three-dimensional array $n_{i,j,k}$ of non-negative integers (with indices $i,j,k \geq 1$) such that $$\sum_{i,j,k} n_{i,j,k}=n$$ and $$n_{i+1,j,k} \leq n_{i,j,k},\quad n_{i,j+1,k} \leq n_{i,j,k},\quad n_{i,j,k+1} \leq n_{i,j,k} \quad \forall i,j,k$$

Is it possible to write a function SolidPartitions[n] that takes as argument a positive integer n and outputs the list of all solid partitions of n?

Suppose I can generate the same list for plane partitions, with the function PlanePartitions, and the function coversplaneQ returns true or false depending on whether or not a certain plane partition is a subset of another one.

The algorithm should run over all integer partitions of $q$ and, for a given integer partition $a=\{a_1,\ldots,a_m\}$ of $q$, run over all plane partitions $p_1 \in PlanePartitions[a_1]$, $p_2 \in PlanePartitions[a_2]$ such that $p_2 \subseteq p_1$ and so on until $p_m$. Every time an allowed entry is obtained, it should add to the list an object of the form $\{p_1,p_2,..,p_m\}$.

I'm not particularly interested in efficiency, namely I'll be using it for values of $q$ below 10. Notice that a plane partition is of the form $\{\{2,1\},\{1\}\}$, while a solid partition is a list of plane partitions, and our function should output a list of solid partitions.

Here's a simple trial, by modifying the plane partitions function:

    SolidPartitions[n_Integer] := Module[{l1, l2, l3, l4, z, w},
     l1 = z @@@ IntegerPartitions[n];
     l2 = l1 /. k_Integer :> w @@ PlanePartitions[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], _?solidpartitionQ]]

where

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

and

coversplaneQ[parent_?planepartitionQ, child_?planepartitionQ] := 
 Block[{dif = Length[parent] - Length[child], p = Length /@ parent, c = PadRight[Length /@ child, Length[parent], 0]}, 
  And[dif >= 0, Min[p - c] >= 0, Min[parent - MapThread[
       PadRight[#1, #2, 0] &, {PadRight[child, Length[parent], {{0}}],p}]] >= 0]]

It seems to give the correct results, but I may still be making some mistake somewehre.

Answer 1

The key to this is indeed recursion. Not only every plane in a solid partition is a plane partition, but sum over planes gives you a linear partition.

We will use the k-Dimensional parition with the help of symbol P (one may use just List, but I am easily get lost in the brackets, so special symbol is better, imho).

P = Symbol["P"];

Now a plane partition will look like P[P[3,2],P[1,1],P[1]].

For PartitionSubset, we use recursive approach:

PartitionSubsetQ[All, a_] := True;
PartitionSubsetQ[A_Integer, a_Integer] := A >= a;
PartitionSubsetQ[A_P, a_P] := And[Length@a <= Length@A,
  And @@ Thread[PartitionSubsetQ[List @@ A[[;; Length[a]]], List @@ a]]]

We determine the behaviour for integers and for larger dimensions, we reduce the comparison to all pairs of smaller dimensions.

In[8]:= PartitionSubsetQ[3, 2]
Out[8]= True

In[9]:= PartitionSubsetQ[P[3, 2], P[3, 3]]
Out[9]= False

In[10]:= PartitionSubsetQ[P[P[3, 2], P[3, 1]], P[P[2, 2], P[2, 1]]]
Out[10]= True

Now, imagine we want to generate partition of dimension $k=2$ for number $n=9$. First, we will generate simple IntegerPartitions. For every number in a partition (for example, {4, 3, 2}) we generate a list of partitions dimension $k-1$.

Arrows on this graph show the relation PartitionSubsetQ. Every path on this graph from top to bottom gives us a new partition of dimension $k$. We can accumulate all of them with the help of dynamic programming.

AddLayerPartition[ppArray_, ipartitions_] := Table[
  ip -> Flatten@
    Table[ Append[#, ip] & /@ arr,
        {arr, 
      Select[ppArray, PartitionSubsetQ[#[[1]], ip] &][[All, 2]]
        }]
  , {ip, ipartitions}]

FromIntegerPartition[ipartition_List, k_Integer: 1] := Fold[
    AddLayerPartition,
    {All -> {P[]}},
    (kPartitions[#, k] & /@ ipartition)][[All, 2]] // Flatten;
kPartitions[n_Integer] := P @@ # & /@ IntegerPartitions[n];
kPartitions[n_Integer, 1] := kPartitions[n]
kPartitions[n_Integer, k_Integer] := 
  Flatten[FromIntegerPartition[#, k - 1] & /@ IntegerPartitions[n]];

Now we are able to generate solid partitions:

In[10]:= kPartitions[4, 3] /. P -> List

Out[10]= {{{{4}}}, {{{3, 1}}}, {{{2, 2}}}, {{{2, 1, 1}}}, {{{1, 1, 1, 1}}},
          {{{3}, {1}}}, {{{2, 1}, {1}}}, {{{1, 1, 1}, {1}}}, {{{2}, {2}}},
          {{{1, 1}, {1, 1}}}, {{{2}, {1}, {1}}}, {{{1, 1}, {1}, {1}}},
          {{{1}, {1}, {1}, {1}}}, {{{3}}, {{1}}}, {{{2, 1}}, {{1}}},
          {{{1, 1, 1}}, {{1}}}, {{{2}, {1}}, {{1}}}, {{{1, 1}, {1}}, {{1}}}, 
          {{{1}, {1}, {1}}, {{1}}}, {{{2}}, {{2}}}, {{{1, 1}}, {{1, 1}}},
          {{{1}, {1}}, {{1}, {1}}}, {{{2}}, {{1}}, {{1}}}, {{{1, 1}}, {{1}}, {{1}}},
          {{{1}, {1}}, {{1}}, {{1}}}, {{{1}}, {{1}}, {{1}}, {{1}}}}

Solid partitions are hard to visualize, but we can show plane partitions nicely:

FramePlanePartition[p_P] := 
 Module[{list = p /. P -> List}, n},
  Framed[TableForm[list, TableSpacing -> {1, 1}]]]

Finally, I want to notice that current function is not fast, but we can speed up things by telling Mathematica to memorize all the internal results:

kPartitions[n_Integer, k_Integer] := kPartitions[n, k] = 
  Flatten[FromIntegerPartition[#, k - 1] & /@ IntegerPartitions[n]]);

With this trick, it's possible to calculate solid partitions of 15 in a couple of seconds:

In[15]:= Length[kPartitions[15, 3]] // Timing

Out[15]= {4.700423, 108802}