Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

share|improve this question
    
What is the specific question you are asking? There is no question stated in your post. For Penrose: geom.uiuc.edu/~crobles/tiling/penrose/inflation.html Code: meta.mathematica.stackexchange.com/a/554/12 –  Szabolcs Jul 23 at 17:39
    
I think the question is "I need to generate nonperiodic tilings"... –  blochwave Jul 23 at 17:58
    
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 Jul 23 at 17:59
    
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 Jul 23 at 18:06
    
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 Jul 23 at 19:16

1 Answer 1

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

share|improve this answer
    
Apparently the rt1s end up forming some of the dominoes and the rt2s end up forming the kites and the rest of the dominoes. –  Rahul Narain Jul 24 at 6:52

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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