Mma functions for generating solid partitions: << DiscreteMath`Combinatorica` Ordering[li_List] := Last /@ Sort[Transpose[{li, Range[Length[li]]}]] coversQ[parent_, child_] := And [ Length[parent] >= Length[child] , Min[Take[ parent, Length@child] - child] >= 0] planepartitionQ[par_] := MatchQ[par, {{___Integer} ..}] && And @@ (OrderedQ /@ Reverse /@ par) && If[Length[par] > 1, And @@ MapThread[coversQ, {Drop[par, -1], Rest[par]}], True] planepartitions[n_Integer] := Module[{w, z, l1, l2, l3, l4}, l1 = z @@@ Partitions[n] ; l2 = l1 /. k_Integer /; (k > 1) :> w @@ Partitions[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], _?planepartitionQ]] 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]] solidform[q_?PartitionQ] := Module[{}, Select[Flatten[Outer[z, Sequence @@ (planepartitions /@ q), 1]], And @@ Apply[coversplaneQ, Partition[# /. z -> List, 2, 1], {1}] &]] solidformBTK[q_?PartitionQ] := If[Length[q] === 1, solidform[q], z @@@ Backtrack[(planepartitions /@ q), And @@ Apply[coversplaneQ, Partition[# , 2, 1] , {1}] &, True &, All]] ------------------------------------- Symmetry operations on solid partitions: flip[par_List] := Module[{wide, it}, wide = Length[par[[1]]]; it = Join[#, Table[0, {wide - Length[#]}]] & /@ par; DeleteCases[ Transpose[it] , 0 | {}, -1]] turn[par_List] := Module[{maks, wide, it}, wide = Length[par[[1]]]; maks = Max[Length[par], wide, Flatten[par]]; it = Join[#, Table[0, {wide - Length[#]}]] & /@ ( par /. i_Integer :> Table[If[w > i, 0, 1], {w, maks}]); DeleteCases[DeleteCases[Transpose[Apply[Plus, it, 1]], 0 | {}, -1], 0 | {}, -1]] (* remark : flip and turn take a plane partition as argument, and should be mapped into a solid partition, working layer by layer; lapse works on an entire solid partition, with Head z, not List *) lapse[li_z] := Module[{i,a}, z @@ (Drop[FixedPointList[#1 /. i_Integer /; i > 0 -> i - 1 //. 0 | {} :> Sequence[] & , li], -2] /. i_Integer -> 1 /. z[a__] :> Apply[Plus, {a}, {2}])] -------------------------------------