# solid partitions generator

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)] /. 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[


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

• The linked to Wikipedia article has something to say about this, under "Exact enumeration using computers." – C. E. Feb 22 '18 at 21:45
• Can you please show how your PlanePartitions work. – yarchik Feb 26 '18 at 21:19
• You greatly improve your chances of getting a good answer if you show your work and then ask for some help here. From the linked page I do not see any working implementations of your imaginary function. – yarchik Feb 26 '18 at 21:30

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].

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:= PartitionSubsetQ[3, 2]
Out= True

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

In:= PartitionSubsetQ[P[P[3, 2], P[3, 1]], P[P[2, 2], P[2, 1]]]
Out= 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[#[], ip] &][[All, 2]]
}]
, {ip, ipartitions}]

FromIntegerPartition[ipartition_List, k_Integer: 1] := Fold[
{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:= kPartitions[4, 3] /. P -> List

Out= {{{{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:= Length[kPartitions[15, 3]] // Timing

Out= {4.700423, 108802}

• Very nice, thanks; indeed it seems to agree with my function above. – jj_p Feb 27 '18 at 3:02