Lozenge tilings

Question

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. — Roman
– Roman, Commented Aug 13, 2020 at 7:05

SHuisman · Accepted Answer · 2020-08-13 10:03:15Z

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] 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[{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? — apg
– apg, Commented 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. — SHuisman
– SHuisman, Commented Aug 13, 2020 at 9:13

C. E. · Accepted Answer · 2020-08-13 10:20:22Z

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

Stack Exchange Network

Lozenge tilings

2 Answers 2

Hot Network Questions