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.
PlanePartitions
work. $\endgroup$