Message Boards Message Boards

Almost indisputable proof of the half-hex cellular automaton

Posted 3 years ago

enter image description here

The chair tiling and the half hexagon tiling:

https://demonstrations.wolfram.com/Code686BuildsTheChairTiling/

https://demonstrations.wolfram.com/LimitPeriodicTilings/

are two of the most well-known standards in the field of aperiodic order, and they are both mentioned in Michael Baake's encyclopedia. It is now known that both chair and half hex tilings can be defined in any one of three ways: by an inflation style substitution rule, as a union of periodic sublattices, or as the output of a cellular automaton. The third technique is not as well known, and the growth rule for the half hexagon tiling is suspected to be either unpublished or unknown. The purpose of this memo is to show that it is easy to derive the rules and to prove that they are correct by brute force.

The strategy is different from that which we used for the Trilobite and Crab tiling, where a binary cellular automaton was already known. Instead of using three symbols for the orientation of the half hexagon tile, we will use three plus one, with the 0 symbol reserved for blank tape. The cellular automaton rules will belong to the special Static Plane Filling class, which is defined by two properties: (1) Only white cells may update, and (2) given some important seed Initial Condition, the rules must ultimately fill the plane. The second condition is more difficult to prove, but will usually reduce to proving the occurrence of increasingly large topological disks as time goes on. It should be noted that the previous solution for trilobite and crab does not use a static plane filling C.A. but obviously such a system of rules can be found (the enthusiastic reader is suggested to try this exercise themselves once they've read and understood the following).

All we need to start is the simple substitution rule, and a depiction function

InflateRep = T[x_, v_] :> Prepend[T[2 x + {Cos[# Pi/3], Sin[# Pi/3]},
       #] & /@ Range[0, 2], T[2 x, v]];
Depict[v_, c_] := {c /. {1 -> Red, 2 -> Green, 3 -> Blue, 0 -> White},Disk[v, 1/2]};
Graphics[Nest[# /. InflateRep &, T[{0, 0}, 0] /. InflateRep, 3] /. T[x_, y_] :> Depict[x, y + 1]]

output

If we use some imagination, this graph already shows the fractal branching structure, which again is not that different from Rule 90. Note the important transformation property that rotation by multiples of 1/6 affect cyclic permutation of the colors. Colors R G B have their own axes to grow along, and between say R & G axes, G branches out R, R branches out G, and B can possibly act as extinction (assuming sufficient surroundings). This logic can also be cyclically permuted. Maybe it's a little amazing that a fourth color ultimately isn't needed, but that's what turns out to happen.

The growth functions are as follows:

RR = {};     

newTileCenters[oldts_, ts_] := Complement[
  Flatten[Outer[#1 + #2 &, ts[[All, 1]],
    {Cos[# Pi/3], Sin[# Pi/3]} & /@ Range[0, 5],
    1], 1], Join[oldts, ts][[All, 1]]]

newTiles[nTCs_, oldts_, ts_] := With[{surround = Outer[
     Cases[Join[oldts, ts], 
        T[#1 + #2, x_] :> x] /. {{} -> 0, {x_} :> x} &,
     nTCs, {Cos[# Pi/3], Sin[# Pi/3]} & /@ Range[0, 5], 1]},
  Sow[Union[surround]];
  DeleteCases[MapThread[T, {nTCs, surround /. RR}], T[_, 0]]]

iterate[0] = {{}, {T[{0, 0}, 1]}};

NextState[oldts_, ts_] := DeleteCases[
  List[Join[oldts, ts], 
   newTiles[newTileCenters[oldts, ts], oldts, ts]],
  T[_, 0], Infinity]

iterate[nn_] :=(*iterate[nn]=*)NextState @@ iterate[nn - 1]

The only reason this doesn't work immediately is that the list of replacement rules RR isn't populated with any values. We just have to go step by step through consecutive instances of time, noting new configurations that occur, writing down whatever rules seem work, and hoping to force extinctions at times $t=2^n$ (as with Trilobite and Crab, it's really not that different). Sometimes this means that we need to assign a zero value, even when neighbors are colored. In those cases, we are waiting for more neighbors to show up before assigning a value. If the entire neighborhood is full, then a value must be assigned. So here is a horrible mess of colorful RGB hacking, not even that bad compared to other more difficult examples:

OnRules = Flatten[Outer[
    RotateRight[{#2, 0, 0, 0, 0, 0}, #1] -> 
      RotateLeft[Range[3], #1][[1]] &,
    Range[0, 5], Range[3]]];

ExtRules = Join[Map[
    RotateLeft[{RotateRight[Range[3], #][[1]], 
        RotateRight[Range[3], #][[2]], 0, 0, 0, 0},
       #] -> RotateRight[Range[3], #][[3]] &, Range[0, 5]],
   Map[RotateLeft[{RotateRight[Range[3], #][[2]], 
        RotateRight[Range[3], #][[1]], 0, 0, 0, 0},
       #] -> RotateRight[Range[3], #][[3]] &, Range[0, 5]]];

ExtRules2 = Join[
   Map[RotateLeft[{RotateRight[Range[3], #][[2]], 
        RotateRight[Range[3], #][[1]], RotateRight[Range[3], #][[1]], 
        0, 0, 0},
       #] -> RotateRight[Range[3], #][[3]] &, Range[0, 5]],
   Map[RotateLeft[{RotateRight[Range[3], #][[2]], 
        RotateRight[Range[3], #][[1]], 0, 0, 0, 
        RotateRight[Range[3], #][[2]]},
       #] -> RotateRight[Range[3], #][[3]] &, Range[0, 5]],
   Map[RotateLeft[{RotateRight[Range[3], #][[2]], 
        RotateRight[Range[3], #][[1]], RotateRight[Range[3], #][[1]],
        0, 0, RotateRight[Range[3], #][[2]]}, #] -> 
      RotateRight[Range[3], #][[3]] &, Range[0, 5]]];

BranchRules = 
  Flatten[Outer[
    RotateLeft[{RotateRight[Range[3], #1][[1]], 
        RotateRight[Range[3], #1][[2]], 0, 0, 0, 0},
       #1 + #2] -> RotateRight[Range[3], #1][[3]] &, 
    Range[0, 5], {1, 2, 4, 5}]];

BranchRules2 = Join[Flatten@Outer[RotateLeft[{
         RotateRight[Range[3], #1][[1]], 
         RotateRight[Range[3], #1][[2]], 0, 0, 0, 
         RotateRight[Range[3], #1][[1]]},
        #1 + #2] -> RotateRight[Range[3], #1][[3]] &, 
     Range[0, 5], {1, 4}],
   Flatten@Outer[RotateLeft[{
         0, RotateRight[Range[3], #1][[1]], 
         RotateRight[Range[3], #1][[2]], 
         RotateRight[Range[3], #1][[2]], 0, 0},
        #1 + #2] -> RotateRight[Range[3], #1][[3]] &, 
     Range[0, 5], {0, 3}]];

WaitRules = 
  Map[RotateLeft[{0, RotateRight[Range[3], #][[1]], 
       RotateRight[Range[3], #][[1]], 0, 0, 0},
      #] -> 0 &, Range[0, 5]];

CollideRules = Join[
   Map[RotateLeft[{0, 0, RotateRight[Range[3], #][[1]], 
        RotateRight[Range[3], #][[2]],
        RotateRight[Range[3], #][[1]], 
        RotateRight[Range[3], #][[2]]},
       #] -> RotateRight[Range[3], #][[3]] &, Range[0, 5]],
   (**)

   Map[RotateLeft[{RotateRight[Range[3], #][[2]], 0, 0, 
        RotateRight[Range[3], #][[2]],
        RotateRight[Range[3], #][[1]], 
        RotateRight[Range[3], #][[1]]},
       #] -> RotateRight[Range[3], #][[3]] &, Range[0, 5]],
   Map[RotateLeft[{RotateRight[Range[3], #][[3]], 0, 0, 
        RotateRight[Range[3], #][[3]],
        RotateRight[Range[3], #][[1]], 
        RotateRight[Range[3], #][[1]]},
       #] -> RotateRight[Range[3], #][[2]] &, Range[0, 5]],
   (**)

   Map[RotateLeft[{RotateRight[Range[3], #][[1]], 0, 0, 
        RotateRight[Range[3], #][[1]], 0, 0},
       #] -> RotateRight[Range[3], #][[1]] &, Range[0, 2]]];

RR = Join[OnRules, ExtRules, BranchRules, ExtRules2, BranchRules2, 
   WaitRules, CollideRules];

Length[RR] == Length[Union@RR]

If it works, it works, and we will now prove that, yes it does.

AbsoluteTiming[ReapData = Reap[iterate[64]];]
RuleAddTimes =  Complement[ReapData[[2, 1, #]], 
    Flatten[ReapData[[2, 1, Range[1, # - 1]]], 1]] & /@ 
  Range[1, Length[ReapData[[2, 1]]]]

Show[ ListPlot[Length /@ RuleAddTimes, AxesOrigin -> {-3, -1}],
 Graphics[Line[{{2^#, 0}, {2^#, 16}}] & /@ Range[6]]]

Rule Generation

The graph shows number of unique rules generated as a function of time, and horizontal lines are placed at time $t=2^n$. After going through three extinctions, we see that no new rules are generated, and take this as good-enough proof of closure of the rule set (purists are complaining, I know, but I also don't really care). Next we check overlap up to time $t=64$:

Function[{nGen}, Complement[
   Flatten[iterate[2^nGen - 1] /. T[x_, y_] :> T[x, y - 1]],
   Union[Flatten[Nest[# /. InflateRep &, T[{0, 0}, 0] /. InflateRep,
         nGen - 1] /. 
        T[x_, y_] :> T[RotationMatrix[# 2 Pi/3].x, Mod[y - #, 3]]
       & /@ Range[0, 2]]]]][6]
Out:={}

If it gets this far, we take that as good-enough proof to infinity (thus avoiding proof by induction). Of course, the part that everyone has been waiting for and looking forward to, pictures and animations:

Graphics[{EdgeForm[Thick], iterate[32] /. T -> Depict}, 
ImageSize -> 800]

static color

static line

dynamic color

dynamic line

How much more can we claim? It seems fairly obvious after working additional, slightly difficult examples that what we are actually seeing is the beginning of a new(?) proof where a large class of aperiodic tilings can be grown by cellular automaton rules. The conjecture is that this large class at least includes any limit-periodic patterns with known substitution rules. The issue is whether the neighborhood will always be no larger than the size of the supertile, and how many colors are necessary. Here's one last example (Rather than Sierpinski's carpet, I've been calling it the Kamakura Vajradhatu Nine-Compartment Thangka, quadrants reflected form):

sierpinski

POSTED BY: Brad Klee
3 Replies

half hex atlas

Half Hex Atlas

The following code is a slightly less-involved derivation of apparently the same rules seen above. (Equivalence of rule sets can be verified in practice by comparing counting functions for sufficiently long time intervals). See also: Whole Hex Rule Derivation.

star = ReIm[Exp[I 2 Pi #/3]] & /@ Range[0, 2];

ToCanonical[vec_] := Subtract[vec, Floor[Divide[vec.{1, 1, 1}, 3] ]]

NeighborLocs[or_, 1] := Map[ToCanonical[or + #] &,
  Riffle[IdentityMatrix[3], RotateRight[-IdentityMatrix[3]]]]

NeighborLocs[or_, n_] := Join[NeighborLocs[or, n - 1],
  Flatten[Partition[NeighborLocs[or, 1], 3, 1, 1]
    /. {x_List, y_List, z_List} :> Map[
      ToCanonical[or + n x + # z] &, Range[0, n - 1]], 1]]

InfM = RotateRight[{2, 0, 0}, #] & /@ Range[0, 2];

InflateRep = {T[x_, v_] :> Prepend[Join[
      T[ToCanonical[InfM.x] + IdentityMatrix[3][[#]], #] & /@ Range[3],
      T[ToCanonical[InfM.x] - IdentityMatrix[3][[#]], #] & /@ 
       Range[3]],
     T[ToCanonical[InfM.x], v]]};

Depict[v_, c_] := {c /. {1 -> Red, 2 -> Green, 3 -> Blue, 0 -> White},
    Disk[v.star, 1/2]};

tilingData = NestList[Union[Flatten[# /. InflateRep]] &,
   T[{0, 0, 0}, 1] /. InflateRep, 4];

NeighborVals[data_, or_] := With[{locs = NeighborLocs[or, 1]},
  ReplaceAll[Cases[data, T[#, dir_] :> dir], {} -> {0}][[1]] & /@ locs]

GetTemplates[data_] := Union[Select[
   NeighborVals[data, #[[1]] ] -> #[[2]] & /@ data,
   ! MemberQ[#[[1]], 0] &]]

AbsoluteTiming[
 templates = GetTemplates /@ tilingData[[1 ;; 4]];
 Length /@ templates;]

DepictTemplate[rule_] := Graphics[{
   Depict[{0, 0, 0}, rule[[2]]],
   MapThread[Depict, {NeighborLocs[{0, 0, 0}, 1], rule[[1]]}]
   }, ImageSize -> 75]

SortedInds = 
  Cases[Position[templates[[-1]], #], {x_, 2} :> x] & /@ Range[1, 3];

GraphicsGrid[
  Partition[DepictTemplate /@ templates[[-1, Flatten[SortedInds]]], 
   8]];

partials[temp_] := 
 ReplacePart[temp, Alternatives @@ # -> _] & /@ Subsets[Range[6]] 

AllPartials = 
  Union[Flatten[partials /@ templates[[3, SortedInds[[#]], 1]], 
      1]] & /@ Range[3];

FilteredPartials = Complement[AllPartials[[#]],
     Flatten[AllPartials[[Complement[Range[3], {#}]]] , 1] ] & /@ 
   Range[3];

Subsets[Range[3], {2}] /. {{x_, y_} :> 
    Intersection[FilteredPartials[[x]], FilteredPartials[[y]]]};

DefiniteRules = {Alternatives @@ FilteredPartials[[1]] -> 1,
   Alternatives @@ FilteredPartials[[2]] -> 2,
   Alternatives @@ FilteredPartials[[3]] -> 3};

OnRules = Flatten[
   Outer[RotateRight[{#2, 0, 0, 0, 0, 0}, #1] -> 
      RotateLeft[Range[3], #1][[1]] &, Range[0, 5], Range[3]]];

ExtRules = Join[Map[
    RotateLeft[{RotateRight[Range[3], #][[1]], 
        RotateRight[Range[3], #][[2]], 0, 0, 0, 0}, #] -> 
      RotateRight[Range[3], #][[3]] &, Range[0, 5]], Map[
    RotateLeft[{RotateRight[Range[3], #][[2]], 
        RotateRight[Range[3], #][[1]], 0, 0, 0, 0}, #] -> 
      RotateRight[Range[3], #][[3]] &, Range[0, 5]]];

CollideRules = Map[
   RotateLeft[{RotateRight[Range[3], #][[1]], 0, 0, 
       RotateRight[Range[3], #][[1]], 0, 0}, #] -> 
     RotateRight[Range[3], #][[1]] &, Range[0, 2]];

AllRules = Join[DefiniteRules,
   OnRules /. {2 -> 3, 3 -> 2},
   ExtRules /. {2 -> 3, 3 -> 2},
   CollideRules /. {2 -> 3, 3 -> 2}];

State0 = {{T[{0, 0, 0}, 1]}, {}};

Iterate[state_] := With[{newVerts = Complement[
     Flatten[NeighborLocs[#, 1] & /@ state[[1, All, 1]], 1],
     Flatten[state[[All, All, 1]], 1]]},
  Flatten /@ {MapThread[
     If[IntegerQ[#2], T[#1, #2], {}] &, {newVerts, 
      ReplaceAll[NeighborVals[Flatten[state], #],
         AllRules] & /@ newVerts}], state}]

Graphics[Flatten[Nest[Iterate, State0, 4 #]] /. T -> Depict] & /@ 
  Range[5];

GrowthData65 = NestList[Iterate, State0, 65];

Complement[Flatten[GrowthData65[[-1]]], 
 Nest[Flatten[# /. InflateRep] &, T[{0, 0, 0}, 1], 7]] 

Out[]={}

Length[#[[1]] ] & /@ GrowthData65
%[[2 ;; -1]]/6
Flatten[Position[%, 3]]
Differences[%]

Out[]={1, 6, 12, 18, 24, 18, 42, 48, 48, 18, 42, 66, 90, 60, 120, 108, 96,
18, 42, 66, 90, 66, 162, 186, 186, 60, 138, 216, 264, 162, 276, 228, 
192, 18, 42, 66, 90, 66, 162, 186, 186, 66, 162, 258, 354, 234, 474, 
426, 378, 60, 138, 216, 282, 234, 528, 600, 552, 162, 366, 570, 630, 
366, 588, 468, 384, 18}

Out[]={1, 2, 3, 4, 3, 7, 8, 8, 3, 7, 11, 15, 10, 20, 18, 16, 3, 7, 11, 15, 
11, 27, 31, 31, 10, 23, 36, 44, 27, 46, 38, 32, 3, 7, 11, 15, 11, 27, 
31, 31, 11, 27, 43, 59, 39, 79, 71, 63, 10, 23, 36, 47, 39, 88, 100, 
92, 27, 61, 95, 105, 61, 98, 78, 64, 3}

Out[]={3, 5, 9, 17, 33, 65}

Out[]={2, 4, 8, 16, 32}

The last output shows log-periodicity with inflation factor $2$, thus the C.A. does have what we called "Ulam Structure" elsewhere. For reference, the $85$ derived rules are:

AllRules2

Out[]={
{0, 0, 0, 0, 0, 1} -> 2
{0, 0, 0, 0, 1, 0} -> 3
{0, 0, 0, 1, 0, 0} -> 1
{0, 0, 1, 0, 0, 0} -> 2
{0, 1, 0, 0, 0, 0} -> 3
{1, 0, 0, 0, 0, 0} -> 1
{0, 0, 0, 0, 0, 2} -> 2
{0, 0, 0, 0, 2, 3} -> 1
{0, 0, 0, 0, 3, 0} -> 3
{0, 0, 0, 3, 1, 0} -> 2
{0, 0, 1, 2, 0, 0} -> 3
{0, 0, 2, 0, 0, 0} -> 2
{0, 2, 3, 0, 0, 0} -> 1
{0, 3, 0, 0, 0, 0} -> 3
{2, 0, 0, 0, 0, 1} -> 3
{3, 1, 0, 0, 0, 0} -> 2
{0, 0, 0, 0, 1, 3} -> 2
{0, 0, 0, 0, 2, 1} -> 3
{0, 0, 0, 2, 1, 0} -> 3
{0, 0, 0, 3, 2, 0} -> 1
{0, 0, 1, 3, 0, 0} -> 2
{0, 0, 3, 2, 0, 0} -> 1
{0, 1, 3, 0, 0, 0} -> 2
{0, 2, 1, 0, 0, 0} -> 3
{2, 0, 0, 0, 0, 3} -> 1
{2, 1, 0, 0, 0, 0} -> 3
{3, 0, 0, 0, 0, 1} -> 2
{3, 2, 0, 0, 0, 0} -> 1
{0, 0, 0, 0, 3, 2} -> 1
{0, 0, 0, 1, 3, 0} -> 2
{0, 0, 2, 1, 0, 0} -> 3
{0, 3, 2, 0, 0, 0} -> 1
{1, 0, 0, 0, 0, 2} -> 3
{1, 3, 0, 0, 0, 0} -> 2
{0, 0, 0, 2, 2, 3} -> 1
{0, 0, 0, 3, 1, 1} -> 2
{0, 0, 1, 2, 2, 0} -> 3
{0, 0, 3, 3, 1, 0} -> 2
{0, 1, 1, 2, 0, 0} -> 3
{0, 2, 3, 3, 0, 0} -> 1
{2, 0, 0, 0, 1, 1} -> 3
{2, 2, 0, 0, 0, 1} -> 3
{2, 2, 3, 0, 0, 0} -> 1
{3, 0, 0, 0, 2, 3} -> 1
{3, 1, 0, 0, 0, 3} -> 2
{3, 1, 1, 0, 0, 0} -> 2
{0, 0, 1, 3, 1, 3} -> 2
{0, 2, 1, 2, 1, 0} -> 3
{2, 0, 0, 3, 2, 3} -> 1
{2, 1, 0, 0, 2, 1} -> 3
{3, 1, 3, 0, 0, 1} -> 2
{3, 2, 3, 2, 0, 0} -> 1
{0, 0, 0, 2, 1, 1} -> 3
{0, 0, 0, 2, 2, 1} -> 3
{0, 0, 3, 2, 2, 0} -> 1
{0, 0, 3, 3, 2, 0} -> 1
{0, 1, 1, 3, 0, 0} -> 2
{0, 1, 3, 3, 0, 0} -> 2
{2, 1, 1, 0, 0, 0} -> 3
{2, 2, 0, 0, 0, 3} -> 1
{2, 2, 1, 0, 0, 0} -> 3
{3, 0, 0, 0, 1, 1} -> 2
{3, 0, 0, 0, 1, 3} -> 2
{3, 2, 0, 0, 0, 3} -> 1
{0, 0, 3, 3, 1, 1} -> 2
{0, 1, 1, 2, 2, 0} -> 3
{2, 2, 0, 0, 1, 1} -> 3
{2, 2, 3, 3, 0, 0} -> 1
{3, 0, 0, 2, 2, 3} -> 1
{3, 1, 1, 0, 0, 3} -> 2
{0, 0, 1, 2, 2, 1} -> 3
{0, 0, 2, 0, 0, 2} -> 2
{0, 0, 3, 2, 2, 3} -> 1
{0, 1, 3, 3, 1, 0} -> 2
{0, 2, 3, 3, 2, 0} -> 1
{0, 3, 0, 0, 3, 0} -> 3
{1, 0, 0, 1, 0, 0} -> 1
{2, 0, 0, 2, 1, 1} -> 3
{2, 1, 1, 2, 0, 0} -> 3
{2, 2, 1, 0, 0, 1} -> 3
{2, 2, 3, 0, 0, 3} -> 1
{3, 0, 0, 3, 1, 1} -> 2
{3, 1, 0, 0, 1, 3} -> 2
{3, 1, 1, 3, 0, 0} -> 2
{3, 2, 0, 0, 2, 3} -> 1
}
POSTED BY: Brad Klee

Here are a few more static plane filling C.A.'s, for the chair tiling (or if you prefer, for the trilobite and crab tiling):

tilted1

The above uses Von-Neumann neighborhood. It can be transformed into the following:

Chair dual

With black for crabs without orientation and colors for trilobites with orientations. When orientations of trilobites are known, orientation of crabs can be obtained by propagating termination signals through channels of the tiling. Another way to evolve the same pattern is as follows:

enter image description here

However notice there is a slight time delay on propagation of colors. This is not really a problem, so perhaps the last solution is the best.

POSTED BY: Brad Klee

enter image description here -- you have earned Featured Contributor Badge enter image description here Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!

POSTED BY: EDITORIAL BOARD

Group Abstract Group Abstract