5
$\begingroup$

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.

$\endgroup$
3
  • $\begingroup$ The linked to Wikipedia article has something to say about this, under "Exact enumeration using computers." $\endgroup$
    – C. E.
    Feb 22, 2018 at 21:45
  • $\begingroup$ Can you please show how your PlanePartitions work. $\endgroup$
    – yarchik
    Feb 26, 2018 at 21:19
  • $\begingroup$ 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. $\endgroup$
    – yarchik
    Feb 26, 2018 at 21:30

1 Answer 1

3
$\begingroup$

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

Partition graph

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

Plane partitions of number 6

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}
$\endgroup$
1
  • $\begingroup$ Very nice, thanks; indeed it seems to agree with my function above. $\endgroup$
    – jj_p
    Feb 27, 2018 at 3:02

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.