I am trying to produce these lozenge tilings as a way of encoding plane partitions. I need to produce something like:
but am using demonstration code like this:
coversQ[parent_, child_] :=
And[Length[parent] >= Length[child],
Min[Take[parent, Length@child] - child] >= 0]
planepartitionQ[par_] :=
MatchQ[par, {{___Integer} ..}] &&
If[Length[par] > 1,
And @@ MapThread[coversQ, {Drop[par, -1], Rest[par]}], True]
PlanePartitions[n_Integer] := Module[{l1, l2, l3, l4, z, w},
l1 = z @@@ IntegerPartitions[n];
l2 = l1 /. k_Integer /; (k > 1) :> w @@ IntegerPartitions[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]
]
PlanePartitionDiagram[l_List] := Module[{i, j, k},
Graphics3D[
Table[Cuboid[{j, -i, k}],
{i, Length[l]},
{j, Length[l[[i]]]},
{k, l[[i, j]]}
]
]
]
Show[PlanePartitionDiagram[{{3, 3, 2, 1}, {0, 3, 2, 1}, {0, 3, 2, 1},
{0, 0, 0, 1}}]]
producing the slightly less pleasing:
Is there a way to produce figures like this lozenge tiling in Mathematica?
ViewPoint -> {Infinity, -Infinity, Infinity}
as an option to get the projected geometry undistorted. $\endgroup$