# Lozenge tilings

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?

• Try ViewPoint -> {Infinity, -Infinity, Infinity} as an option to get the projected geometry undistorted. Aug 13, 2020 at 7:05

You can add the options ViewProjection, ViewPoint, and ViewVertical to make it appear as if it isometric:

coversQ[parent_,child_]:=And[Length[parent]>=Length[child],Min[Take[parent,Length@child]-child]>=0]

PlanePartitions[n_Integer]:=Module[{l1,l2,l3,l4,z,w},l1=z@@@IntegerPartitions[n];
l2=l1/.k_Integer/;(k>1):>w@@IntegerPartitions[k];
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[{EdgeForm[{Black,Thickness[0.01]}],
Table[
Cuboid[{j,-i,k}]
,
{i,Length[l]},
{j,Length[l[[i]]]},
{k,l[[i,j]]}
]},
Boxed->False,
ViewProjection->"Orthographic",
ViewPoint->{1,1,1},
Lighting -> {{"Directional",
Yellow, {{0, 0, 1}, {0, 0, 0}}}, {"Directional",
Blue, {{0, 1, 0}, {0, 0, 0}}}, {"Directional",
Red, {{1, 0, 0}, {0, 0, 0}}}}
]
]
PlanePartitionDiagram[{{3,3,2,1},{0,3,2,1},{0,3,2,1},{0,0,0,1}}]


(should work with 11.2 and up).

• Is it possible to remove the frame, and colour the walls with cells of the respective colour?
– apkg
Aug 13, 2020 at 9:10
• Boxed -> False option removes the box around it. Perhaps the coloring can be achieved by placing lights strategically in certain, see the documentation of Lighting reference.wolfram.com/language/ref/Lighting.html Otherwise one has to decompose the cubes into polygons with different colors. Aug 13, 2020 at 9:13
• Ok, the boxed option is in the Graphics3D part?
– apkg
Aug 13, 2020 at 9:14
• Yes, or the Show. Aug 13, 2020 at 9:15
• I've modified my answer to reflect the right colors… Aug 13, 2020 at 10:01

Here is different way to achieve the coloring:

PlanePartitionDiagram[l_List, col_, {offsetx_, offsety_, offsetz_}] :=
Module[{i, j, k},
Graphics3D[
Prepend[Glow[col]]@Table[
Cuboid[{j + offsetx, -i + offsety, k + offsetz}],
{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}}, Red, {10^-2, 0, 0}],
PlanePartitionDiagram[{{3, 3, 2, 1}, {0, 3, 2, 1}, {0, 3, 2, 1}, {0, 0, 0, 1}}, Blue, {0, 10^-2, 0}],
PlanePartitionDiagram[{{3, 3, 2, 1}, {0, 3, 2, 1}, {0, 3, 2, 1}, {0, 0, 0, 1}}, Yellow, {0, 0, 10^-2}],
Lighting -> None,
Boxed -> False,
ViewProjection -> "Orthographic"
]