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

-------------------------------------