9
$\begingroup$

I am trying to produce these lozenge tilings as a way of encoding plane partitions. I need to produce something like:

enter image description here

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:

enter image description here

Is there a way to produce figures like this lozenge tiling in Mathematica?

| improve this question | |
$\endgroup$
  • 3
    $\begingroup$ Try ViewPoint -> {Infinity, -Infinity, Infinity} as an option to get the projected geometry undistorted. $\endgroup$ – Roman Aug 13 at 7:05
9
$\begingroup$

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).

enter image description here

| improve this answer | |
$\endgroup$
  • 1
    $\begingroup$ Is it possible to remove the frame, and colour the walls with cells of the respective colour? $\endgroup$ – apkg Aug 13 at 9:10
  • 1
    $\begingroup$ 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. $\endgroup$ – SHuisman Aug 13 at 9:13
  • 1
    $\begingroup$ Ok, the boxed option is in the Graphics3D part? $\endgroup$ – apkg Aug 13 at 9:14
  • 1
    $\begingroup$ Yes, or the Show. $\endgroup$ – SHuisman Aug 13 at 9:15
  • 1
    $\begingroup$ I've modified my answer to reflect the right colors… $\endgroup$ – SHuisman Aug 13 at 10:01
3
$\begingroup$

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

enter image description here

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.