Message Boards Message Boards

The Penrose tiling: casting night and day

Brad Klee, Wolfram Research
Posted 2 years ago

Penrose Star Penrose Sun

In two previous posts on plane patterns, we discuss the relation between substitution systems, cellular automata and template atlases. Another plane pattern, the Penrose tiling, presents considerable difficulties in the form of non-crystallographic symmetry. Most people wouldn't bother to try and find a growth function, but we have two reasons to do just that. First, growth functions introduce a time variable, so provide a way from mathematical structure into physical process, thus toward the realm of quasicrystals. Second, perhaps more importantly, we would like to spend some of our limited time on this earth in the pursuit of pure beauty (even though pursuit of pure beauty might also be pursuit of total misery).

We need some functions to draw the actual tiles. To make the growth process easier, we put control points on every vertex, and allow for ten distinct orientations:

DepictThin[or_, v_, r_] := With[{verts = {{0, 0},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]}
      + {Cos[2 (r - 1) Pi/10], Sin[2 (r - 1) Pi/10]},
     {Cos[2 (r - 1) Pi/10], Sin[2 (r - 1) Pi/10]}}},
  {White, Polygon[Expand@Plus[or, #, Part[-verts, v]] & /@ verts],
   Lighter@Red, 
   Disk[or + Part[-verts, v] + verts[[2]], 
    1/4, {2 (r - 1) Pi/10, 2 (r - 5) Pi/10}],
   Lighter@Purple, 
   Disk[or + Part[-verts, v] + verts[[4]], 
    1/4, {2 (r) Pi/10, 2 (r + 4) Pi/10}]}]

DepictFat[or_, v_, r_] := With[{verts = {{0, 0},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]}
      + {Cos[2 (r - 2) Pi/10], Sin[2 (r - 2) Pi/10]},
     {Cos[2 (r - 2) Pi/10], Sin[2 (r - 2) Pi/10]}}},
  {White, Polygon[Expand@Plus[or, #, Part[-verts, v]] & /@ verts],
   Lighter@Purple, Disk[or + Part[-verts, v] + verts[[1]],
    1/4, {2 (r) Pi/10, 2 (r - 2) Pi/10}],
   Lighter@Red, Disk[or + Part[-verts, v] + verts[[3]],
    1, {2 (r + 5) Pi/10, 2 (r + 3) Pi/10}],
   White, Disk[or + Part[-verts, v] + verts[[3]],
    3/4, {2 (r + 5) Pi/10, 2 (r + 3) Pi/10}]}]
DepictRule = {TF -> DepictFat, TT -> DepictThin};

Fat and Thin

The one tile is usually called fat and the other thin. These tiles have matching rules, so they can only group around a vertex in one of eight legal vertex figures (in this case, vertex figures are essentially the same thing as what NKS calls templates). The atlas of all possible vertex figures is written out fully as:

Stars = Function[{off}, TF[{0, 0}, 1, 2 # - off] & /@ Range[5]] /@ {0,1};
Suns = Function[{off}, TF[{0, 0}, 3, 2 # - off] & /@ Range[5]] /@ {0, 1};
FHexes = Map[{TF[{0, 0}, 2, Mod[2 + #, 10]], 
     TF[{0, 0}, 4, Mod[4 + #, 10]],
     TT[{0, 0}, 2, Mod[5 + #, 10]]} &, Range[10]];
Crowns = Map[{TF[{0, 0}, 4, Mod[2 + #, 10]], 
     TF[{0, 0}, 2, Mod[4 + #, 10]],
     TT[{0, 0}, 3, Mod[4 + #, 10]], TF[{0, 0}, 3, Mod[3 + #, 10]],
     TT[{0, 0}, 1, Mod[6 + #, 10]]} &, Range[10]];
Boats = Map[{TF[{0, 0}, 1, Mod[6 + #, 10]], 
     TF[{0, 0}, 1, Mod[4 + #, 10]],
     TF[{0, 0}, 1, Mod[2 + #, 10]], TT[{0, 0}, 4, Mod[6 + #, 10]]} &, 
   Range[10]];
Splits = Map[{TF[{0, 0}, 3, Mod[#, 10]], TF[{0, 0}, 3, Mod[2 + #, 10]],
     TF[{0, 0}, 3, Mod[4 + #, 10]], TF[{0, 0}, 3, Mod[6 + #, 10]],
     TT[{0, 0}, 3, Mod[7 + #, 10]], TT[{0, 0}, 1, Mod[3 + #, 10]]} &, 
   Range[10]];
Wings = Map[{TT[{0, 0}, 1, Mod[7 + #, 10]], 
     TT[{0, 0}, 3, Mod[1 + #, 10]],
     TF[{0, 0}, 3, Mod[#, 10]],
     TT[{0, 0}, 1, Mod[3 + #, 10]], TT[{0, 0}, 3, Mod[7 + #, 10]],
     TF[{0, 0}, 3, Mod[6 + #, 10]], TF[{0, 0}, 3, Mod[4 + #, 10]]
     } &, Range[10]];
THexes = Map[{TT[{0, 0}, 4, Mod[#, 10]], TT[{0, 0}, 4, Mod[4 + #, 10]],
     TF[{0, 0}, 1, Mod[#, 10]]} &, Range[10]];
AllFigures = List[Suns, Stars, FHexes, Crowns, Boats, Splits, Wings, THexes];

Partition[Map[Graphics[{EdgeForm[Black], # /. DepictRule},
     PlotRange -> {{-2, 2}, {-2, 2}}, ImageSize -> 100] &,
   AllFigures[[All, 1]], {1}], 4] // TableForm

Penrose Vertices

Assume that we have a partially complete tiling and would like to add more tiles along the boundary. To do so, we need to know: which partial configurations have a unique completion? To answer this question, we simply calculate all possible partial configurations and notice when some are unique, while others project down from multiple vertex figures. The combinatorics can be programmed, so it ultimately requires very little thought: 

FatEdges[or_, v_, r_] := With[{verts = {{0, 0},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]}
      + {Cos[2 (r - 2) Pi/10], Sin[2 (r - 2) Pi/10]},
     {Cos[2 (r - 2) Pi/10], Sin[2 (r - 2) Pi/10]}}},
  Function[{verts},
    {FC[verts[[1]], Mod[r, 10]], TC[verts[[2]], Mod[r + 5, 10]],
     FC[verts[[1]], Mod[r - 2, 10]], TC[verts[[4]], Mod[r + 3, 10]],
     FR[verts[[4]], Mod[r, 10]], TR[verts[[3]], Mod[r + 5, 10]],
     FR[verts[[2]], Mod[r - 2, 10]], TR[verts[[3]], Mod[r + 3, 10]]}
    ][Expand@Plus[or, #, Part[-verts, v]] & /@ verts]]

ThinEdges[or_, v_, r_] := With[{verts = {{0, 0},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]},
     {Cos[2 r Pi/10], Sin[2 r Pi/10]}
      + {Cos[2 (r - 1) Pi/10], Sin[2 (r - 1) Pi/10]},
     {Cos[2 (r - 1) Pi/10], Sin[2 (r - 1) Pi/10]}}},
  Function[{verts},
    {TR[verts[[1]], Mod[r, 10]], FR[verts[[2]], Mod[r + 5, 10]],
     TC[verts[[1]], Mod[r - 1, 10]], FC[verts[[4]], Mod[r + 4, 10]],
     FC[verts[[4]], Mod[r, 10]], TC[verts[[3]], Mod[r + 5, 10]],
     FR[verts[[2]], Mod[r - 1, 10]], TR[verts[[3]], Mod[r + 4, 10]]}
    ][Expand@Plus[or, #, Part[-verts, v]] & /@ verts]]

EdgesRule = {TF -> FatEdges, TT -> ThinEdges};

ProjectRules[figure_] := Rule @@ # & /@ Map[List[ Sort[
  Cases[figure[[1 ;; #]] /. EdgesRule, xF_[{0, 0}, yr_] :> xF[yr],
    Infinity]],
 figure[[#1 + 1 ;; -1]] ] &, Range[2, Length[figure] - 1]]

CompletionMap = Flatten[Map[Function[{rot}, ProjectRules[RotateRight[#, rot]]
     ] /@ Range[Length[#]] &, #] & /@ AllFigures];

UniqueCompletion = Cases[Tally[CompletionMap[[All, 1]]], {x_, 1} :> x];

UniqueMap = MapThread[ Rule, {UniqueCompletion, UniqueCompletion /. CompletionMap}];

AddRep[or_] := ReplaceAll[UniqueMap, {0, 0} -> or]

To see what we've done here (quite a lot by data structure and mapping), let's add another intermediary depiction function. There are $410$ total rules in AddRep, so we will only plot a random sample of 16:

DepictAddRule[rule_] := Show[Reverse[Map[Graphics[{EdgeForm[Thin],
       Arrowheads[.1], Thick, # /. DepictRule},
      ImageSize -> 150, PlotRange -> {{-2, 2}, {-2, 2}}] &, rule /. 
      Rule -> List /. {FR[r_] :> {Red, 
        Arrow[{{Cos[r Pi/5], Sin[r Pi/5]}, {0, 0}}]},
      FC[r_] :> {Blue, Arrow[{{Cos[r Pi/5], Sin[r Pi/5]}, {0, 0}}]},
      TR[r_] :> {Red, 
        Arrow[Reverse@{{Cos[r Pi/5], Sin[r Pi/5]}, {0, 0}}]},
      TC[r_] :> {Blue, 
        Arrow[Reverse@{{Cos[r Pi/5], Sin[r Pi/5]}, {0, 0}}]}}, 1]]]

Partition[DepictAddRule /@ RandomSample[AddRep[{0, 0}], 16], 
  4] // TableForm

update rules

Basically, each image says that if we find this particular configuration of edge vectors in a partially complete tiling, then we should add one or more tiles, as depicted, to complete the figure. This is all good, but if we try to use only these $410$ rules, we quickly meet ambiguous conditions where we must choose one of two alternatives:

alternatives

In another beautiful apparition of parity symmetry, it turns out the first alternative is better for growing the Night configuration, while the second is better for Day. All that's left is to define iterators and axioms as follows: 

StarFailSafe[or_] := Join[
  Sort[{TC[Mod[2 + #, 10]], TC[Mod[6 + #, 10]], TR[Mod[3 + #, 10]], 
       TR[Mod[3 + #, 10]], TR[Mod[5 + #, 10]],
       TR[Mod[5 + #, 10]]}] -> {TF[or, 2, # + 1], 
      TF[or, 4, # - 1]} & /@ Range[10]]

SunFailSafe[or_] := Join[Sort[
      {TC[Mod[2 + #, 10]], TC[Mod[6 + #, 10]], TR[Mod[3 + #, 10]], 
       TR[Mod[3 + #, 10]], TR[Mod[5 + #, 10]],
       TR[Mod[5 + #, 10]]}] -> {TF[or, 3, # + 6], TF[or, 3, # + 4], 
      TT[or, 1, # - 3], TT[or, 3, # + 7]} & /@ Range[10],
  Sort[{TC[Mod[# + 1, 10]], TC[Mod[# + 1, 10]], TR[Mod[#, 10]], 
       TR[Mod[#, 10]],
       TR[Mod[# + 2, 10]], TR[Mod[# + 2, 10]], TR[Mod[# + 4, 10]], 
       TR[Mod[# + 8, 10]]
       }] -> {TF[or, 3, Mod[1 + #, 10]], 
      TF[or, 3, Mod[3 + #, 10]]} & /@ Range[10]]

CompleteFigures =   Map[Sort[Cases[# /. EdgesRule, xF_[{0, 0}, yr_] :> xF[yr], 
      Infinity]] &,   Flatten[AllFigures, 1]];

 IterateSunFS[state_, comp_] := With[{VertexFigures = Function[{edges},
      V[#, Sort[Cases[edges, x_[#, y_] :> x[y]]]] & /@ (
        Complement[Union[edges[[All, 1]]], comp])][
     Flatten[Union[state /. EdgesRule]]]},
  {Join[state, If[Length[#] == 0, Print["^"];
       With[{hits = 
          Cases[VertexFigures /. 
            V[or_, edges_] :> (edges /. SunFailSafe[or]), 
           TT[__] | TF[__], Infinity]},
        Sow[hits]; hits], #] &@
     Cases[VertexFigures /. V[or_, edges_] :> (edges /. AddRep[or]), 
      TT[__] | TF[__], Infinity]],
   Join[comp, 
    Cases[VertexFigures, 
     V[x_, Alternatives @@ CompleteFigures] :> x]]}]

IterateStarFS[state_, comp_] := With[{VertexFigures = Function[{edges},
      V[#, Sort[Cases[edges, x_[#, y_] :> x[y]]]] & /@ (
        Complement[Union[edges[[All, 1]]], comp])][
     Flatten[Union[state /. EdgesRule]]]},
  {Join[state, If[Length[#] == 0, Print["^"];
       With[{hits = 
          Cases[VertexFigures /. 
            V[or_, edges_] :> (edges /. StarFailSafe[or]), 
           TT[__] | TF[__], Infinity]},
        Sow[hits]; hits], #] &@
     Cases[VertexFigures /. V[or_, edges_] :> (edges /. AddRep[or]), 
      TT[__] | TF[__], Infinity]],
   Join[comp, 
    Cases[VertexFigures, 
     V[x_, Alternatives @@ CompleteFigures] :> x]]}]

AxiomA = TF[{0, 0}, 1, 2 #] & /@ Range[5];
StateA1 = {AxiomA, {{0, 0}}};
AxiomB = TF[{0, 0}, 3, 2 #] & /@ Range[5];
StateB1 = {AxiomB, {{0, 0}}};

Now we can generate successive configurations and make a plot of where we were forced to make an arbitrary choice to continue growing the tiling. For the night configuration, we have, after about $35$ iterations: 

AbsoluteTiming[ AData = Reap[NestList[IterateStarFS @@ # &, StateA1, 40]];]
Graphics[{EdgeForm[Black], AData[[1, -5, 1]] /. DepictRule, 
  Map[Disk[#, 1/3] &,   Union[Flatten[AData[[2, 1, All, All, 1]], 1]]]}, ImageSize -> 800]

ChoicesA

And for the Day configuration, we have, after about $45$ iterations: 

AbsoluteTiming[ data = Reap[NestList[IterateSunFS @@ # &, StateB1, 50]];]

Graphics[{EdgeForm[Black], data[[1, -5, 1]] /. DepictRule, 
  Map[Disk[#, 1/3] &,
   Union[Flatten[data[[2, 1, All, All, 1]], 1]]]}, ImageSize -> 800]

Choices B

Using the same code, we can easily check both patterns up to $t\approx 150$, which gets us past the fourth or fifth wave / corona, in terms of light-red loops drawn around the pattern center. This very strongly suggests that the algorithm as presented here will grow patterns indefinitely. However, a little more work remains to be done to make the algorithm a proper Cellular Automaton algorithm. This can likely be accomplished by adding an extra binary variable at all binary-ambiguous vertices. This project we leave for another day...
POSTED BY: Brad Klee
6 Replies
Sort By:
POSTED BY: Brad Klee

combined grow

After correcting an error in the above process, I decided to double check using an entirely different algorithm. The new technique (still under development) does not use tiles, but instead grows the triality pattern directly by adding branches at each successive iteration. This process produces a slightly different count: 

Length[Union[Flatten[#][[All, 1]]]] & /@ stateList[[1 ;; 24]]
Differences[%]/5
Subtract[%, {1, 2, 1, 3, 5, 2, 6, 4, 3, 4, 4, 3, 9, 14, 5, 13, 9, 6, 8, 8, 6, 18, 13}]

Out[]:= {1, 6, 16, 21, 36, 61, 71, 101, 131, 146, 156, 176, 191, 236, 306,
331, 396, 461, 491, 511, 551, 581, 671, 771}
Out[]:={1, 2, 1, 3, 5, 2, 6, 6, 3, 2, 4, 3, 9, 14, 5, 13, 13, 6, 4, 8, 6, 18, 20}
Out[]:={0, 0, 0, 0, 0, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 4, 0, -4, 0, 0, 0,7}

At some times, the branching algorithm grows slightly faster than the tiling algorithm, which then catches up after two steps.

The agreement of these result is very exciting, but minor disagreements show that we still don't know exactly how to define the growth sequence. The growth algorithm runs smoothly up to about $t \sim 45$, and then we may need to rethink conditional rules. We'll see what happens soon...
POSTED BY: Brad Klee

Fully Synchronized Penrose Tiling

Synchronization is important to long range order, since it can effectively prevent patterns of destructive interference from introducing wrong configurations. While mathematically perfect growth functions may not ever occur in the quasicrystal lab, they can certainly give us insight to what may happen there. The biggest takeaway (which is hinted at in Socolar's "Growth Rules for Quasicrystals") is that frustration is an important part of growing Ulam structures. Snowflakes tend to grow on corners due to sharpness of the electromagnetic field, so perhaps a similar mechanism affects quasicrystals.

Now that we have a perfectly synchronized function up to time $t \sim 100$, we can calculate the growth sequences fairly easily: 

Length /@ AStates[[All, 2, 2]]
Differences[%]
Divide[%% - 1, 5]
Divide[%%, 5]
Transpose[Partition[%, 4]]

(* editor's note: these sequences have been corrected on Oct. 26 *)
Out[] 1, 1, 6, 6, 6, 6, 16, 16, 16, 16, 21, 21, 21, 21, 36, 36, 
36, 36, 61, 61, 61, 61, 71, 71, 71, 71, 101, 101, 101, 101, 121, 121, 
121, 121, 136, 136, 136, 136, 156, 156, 156, 156, 176, 176, 176, 176, 
191, 191, 191, 191, 236, 236, 236, 236, 306, 306, 306, 306, 331, 331, 
331, 331, 396, 396, 396, 396, 441, 441, 441, 441, 471, 471, 471, 471, 
511, 511, 511, 511, 551, 551, 551, 551, 581, 581, 581, 581, 671, 671, 
671, 671, 736, 736, 736, 736, 751, 751, 756}
Out[]:= {0, 0, 0, 0, 5, 0, 0, 0, 10, 0, 0, 0, 5, 0, 0, 0, 15, 0, 0, 0, 25, 0, 
0, 0, 10, 0, 0, 0, 30, 0, 0, 0, 20, 0, 0, 0, 15, 0, 0, 0, 20, 0, 0, 
0, 20, 0, 0, 0, 15, 0, 0, 0, 45, 0, 0, 0, 70, 0, 0, 0, 25, 0, 0, 0, 
65, 0, 0, 0, 45, 0, 0, 0, 30, 0, 0, 0, 40, 0, 0, 0, 40, 0, 0, 0, 30, 
0, 0, 0, 90, 0, 0, 0, 65, 0, 0, 0, 15, 0, 5} (* note sync breaking *)
Out[]:= {0, 0, 0, 0, 0, 1, 1, 1, 1, 3, 3, 3, 3, 4, 4, 4, 4, 7, 7, 7, 7, 12, 
12, 12, 12, 14, 14, 14, 14, 20, 20, 20, 20, 24, 24, 24, 24, 27, 27, 
27, 27, 31, 31, 31, 31, 35, 35, 35, 35, 38, 38, 38, 38, 47, 47, 47, 
47, 61, 61, 61, 61, 66, 66, 66, 66, 79, 79, 79, 79, 88, 88, 88, 88, 
94, 94, 94, 94, 102, 102, 102, 102, 110, 110, 110, 110, 116, 116, 
116, 116, 134, 134, 134, 134, 147, 147, 147, 147, 150, 150, 151}
Out[]:={0, 0, 0, 0, 1, 0, 0, 0, 2, 0, 0, 0, 1, 0, 0, 0, 3, 0, 0, 0, 5, 0, 0, 
0, 2, 0, 0, 0, 6, 0, 0, 0, 4, 0, 0, 0, 3, 0, 0, 0, 4, 0, 0, 0, 4, 0, 
0, 0, 3, 0, 0, 0, 9, 0, 0, 0, 14, 0, 0, 0, 5, 0, 0, 0, 13, 0, 0, 0, 
9, 0, 0, 0, 6, 0, 0, 0, 8, 0, 0, 0, 8, 0, 0, 0, 6, 0, 0, 0, 18, 0, 0, 
0, 13, 0, 0, 0, 3, 0, 1}
Out[]:= {
{0, 1, 2, 1, 3, 5, 2, 6, 4, 3, 4, 4, 3, 9, 14, 5, 13, 9, 6, 8, 8, 6, 18, 13}, 
{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, 
{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, 
{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}}

The first sequence is the number of suns turned on at time $t$. None of these integer sequences appear to be on OEIS, though many similar sequences are. Actually, the growth algorithm is fairly difficult to program, so it's more likely that OEIS would have something on the triality pattern itself, for example: 

Length /@ NestList[Function[{verts}, Union@Join[Flatten[
      Nearest[Complement[AStates[[-1, 2, 2]] , verts ], #] & /@ verts,
       1], verts]], {{0, 0}}, 10]
Divide[% - 1, 5]
Differences[%]
Differences[%%%]

Out[276]= {1, 6, 16, 21, 36, 61, 81, 106, 136, 176, 211}
Out[277]= {0, 1, 3, 4, 7, 12, 16, 21, 27, 35, 42}
Out[278]= {1, 2, 1, 3, 5, 4, 5, 6, 8, 7}
Out[279]= {5, 10, 5, 15, 25, 20, 25, 30, 40, 35}

Neither do any of these appear in OEIS, so perhaps we are really doing something fun and original here.

POSTED BY: Brad Klee

It appears that slight modification of the growth rules allows for synchronization of star-center turn-ons. This looks to be leading toward verification of a log-periodic Ulam Structure: at times $t = k^n, n \in 1, 2, \ldots$ the growth function goes extinct except for singular sources at each of five pentagonal corners (which alternate between even / odd $D_{10}$ axes as $n$ increases). The following animation goes through $n=1$ and $n=2$ with only a few sync errors:

Fractal Penrose
POSTED BY: Brad Klee
POSTED BY: Brad Klee
POSTED BY: Moderation Team
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract