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]]
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]]]
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]
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):