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$
1
  • 3
    $\begingroup$ Try ViewPoint -> {Infinity, -Infinity, Infinity} as an option to get the projected geometry undistorted. $\endgroup$
    – Roman
    Aug 13, 2020 at 7:05

2 Answers 2

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