How to generate nonperiodic tilings?

13

8

I need to generate nonperiodic tilings which are similar to the attached figure (kite-domino tiling). I was thinking the code is similar to the code for the Penrose tiling. However, that code is too complicated for me to digest at this time.

Kite-Domino Tiling

user18735

Posted 2014-07-23T17:01:26.160

Reputation: 141

1

What is the specific question you are asking? There is no question stated in your post. For Penrose: http://www.geom.uiuc.edu/~crobles/tiling/penrose/inflation.html Code: http://meta.mathematica.stackexchange.com/a/554/12

– Szabolcs – 2014-07-23T17:39:39.613

I think the question is "I need to generate nonperiodic tilings"... – dr.blochwave – 2014-07-23T17:58:44.723

This looks to me to be a pure Tom Sawyer request. The OP seems to be saying "This problem is too hard for me, so will someone do it for me?". I say: close it as too broad. – m_goldberg – 2014-07-23T17:59:27.840

Looking at the image and seeing there is a sub-tiling that forms a rectangle, it seems clear that a periodic tiling is possible with kite and rectangle tiles. In fact, I can see at least three different periodic tilings. – m_goldberg – 2014-07-23T18:06:46.170

For generating self-similar non-periodic tilings, like the Penrose tiling, the simplest method is to recursively subdivide the tiles. You'll find a lot of information on this if you search for "deflation". For implementing this in Mathematica you can use some recursive programming, the same way e.g. Koch curves are generated. – Szabolcs – 2014-07-23T19:16:04.970

Answers

26

The kite-domino tiling is based the pinwheel tiling which is falls out of a particular decomposition of a right triangle with legs of length 1 and 2. In the code that follows, rt[{a,b,c}] represents such a right triangle and dissect indicates how such a triangle should be decomposed into smaller copies of itself. We simply iterate the dissect function on an initial configuration.

dissect[rt[{a_, b_, c_}]] := Module[
   {d, e, f, g},
   d = c + ((a - c).(b - c))/((a - c).(a - c)) (a - c) // N;
   e = (a + b)/2 // N;
   f = b + ((d - b).(e - b))/((d - b).(d - b)) (d - b) // N;
   g = a + ((e - a).(c - a))/((c - a).(c - a)) (c - a) // N;
   {rt[{a, g, e}], rt[{d, g, e}], 
    rt[{e, f, d}], rt[{e, f, b}],
    rt[{b, d, c}]}];
dissect[l_List] := dissect /@ l;
init = {rt[{{0, 0}, {2, 0}, {2, 1}}]};
iterated = NestList[dissect, init, 2];
GraphicsColumn[Graphics[{
     {Thick, Line[{{0, 0}, {2, 0}, {2, 1}, {0, 0}}]}, 
     # /. rt[{a_, b_, c_}] ->
       {Opacity[0.6], Line[{a, b, c, a}]}}] & /@ iterated]

enter image description here

Now, if we merely delete each hypotenuse, we already obtain something close to what you want. We can also expand the initial configuration to include a whole rectangle.

init = {rt[{{0, 0}, {2, 0}, {2, 1}}], rt[{{2, 1}, {0, 1}, {0, 0}}]};
Graphics[Nest[dissect, init, 4] /. rt[{a_, b_, c_}] -> Line[{a, b, c}]]

enter image description here

It's trickier to distinguish the kites from the dominoes. I'm certain there's a better way to do this, but one approach is to merge the triangles we've just generated. This is not so simple because, often, the a1 in rt[{a1,b,c1}] and the a2 in rt[{a2,d,c1}] may be very close but not equal. The following attempts to deal with that

Needs["HierarchicalClustering`"]
canonicalFunction[nonCanonicalValues_List] := Module[
      {heirarchy, MyClusters, segregate, cf, clusters, 
    canonicalValues},
      Quiet[heirarchy = Agglomerate[N[nonCanonicalValues],
              DistanceFunction -> EuclideanDistance,
              Linkage -> "Average"]];
      segregate[Cluster[cl1_, cl2_, d_, _, _], tol_] :=   
    MyClusters[cl1, cl2] /; d > tol;
      segregate[mine_MyClusters, tol_] := 
    segregate[#, tol] & /@ mine;
      segregate[x_, _] := x;
      cf[cl_Cluster] := ClusterFlatten[cl];
      cf[x_] := {x};
      clusters = cf /@ 
     List @@ Flatten[FixedPoint[segregate[#, 10^(-12)] &,
                        MyClusters[heirarchy]]];
      canonicalValues = Chop[First /@ clusters];
      toCanonical[x_] := First[Nearest[canonicalValues][x]];
      toCanonical];
pts = Partition[Flatten[iterated /. rt -> Sequence], 2];
cf = canonicalFunction[pts];
gathered = 
  GatherBy[Flatten[iterated], Sort[cf /@ {#[[1, 1]], #[[1, 3]]}] &];
preserved = Select[gathered, #[[1, 1, 1]] == #[[2, 1, 1]] &];
flipped = Select[gathered, #[[1, 1, 1]] == #[[2, 1, 3]] &];
join[{rt[{a_, b_, c_}], rt[{_, d_, _}]}] := Polygon[{a, b, c, d}];
Graphics[{EdgeForm[Black],
  {Darker[Red], join /@ flipped},
  {Gray, join /@ preserved}
  }]

enter image description here

Mark McClure

Posted 2014-07-23T17:01:26.160

Reputation: 31 084

Apparently the rt1s end up forming some of the dominoes and the rt2s end up forming the kites and the rest of the dominoes. – None – 2014-07-24T06:52:30.213

The next step is of course to produce the 3D analog with Quaquaversal tilling :-) – chris – 2014-11-14T16:05:07.090