# A Sierpinski-ish structure, via 2D automata

The project is originally based on a puzzle proposed by EIORU at http://www.ptt.cc/bbs/puzzle/M.1342451949.A.00F.html (若您懂得讀中文 / if anyone happen to read Chinese^^) last July.

The descriptions, simply put, are as follows:

1. Initially on a x-y plane at the origin there's a vertical stem, length = 1.
2. The stem grow two twigs. One to the east and the other to the west. the twigs are of 45° polar angle, length = $\sqrt{2}$. Now the tree looks like an "Y".
3. All twigs then grow vertical stems on their tip, length = 1.
4. / The stems on eastward twigs lead to a east/west forking of twigs.

/ The stems on westward twigs lead to a north/south forking of twigs.

5. The growing iteration continues such that:

/ The stem on a northward twig grow like a westward twig.

/ The stem on a southward twig grow like a eastward twig.

/ Whenever two twigs converge at some location, a fruit is formed and no further growing takes place.

Q1: How many iterations does it take that >100 fruits are on the tree?

Q2: What's the total length of stems and twigs at Q1's iteration?

This "EIORU tree", is equivalent to a square 2-D automata, and the rules are easily translated to automata rules (for conciseness I'll skip listing them :P)

I wrote some Mathematica code to visualize such structure. The code works out, however is rather inefficient. If you find it interesting please advise me ways to efficientize it, thanks!

Clear[tree]; tree[vertical][0] = {{0, 0} -> "W"}; tree[vertical][n_] /; n>0 :=
tree[vertical][n] = (tree[diagonal][n] = Sort[tree[vertical][n - 1] /. rule1])
//. {p___, q_Rule, r___, s_Rule, t___} /; q[[1]] == s[[1]] :> {p, q[[1]] -> "Q", t}
(*iterate level by level. my method of removing Q=fruit from the next level is clumsy*)
rule1 = {
(*W*)({x_, y_} -> "W"):> Sequence[{x, y + 1} -> "W", {x, y - 1} -> "S"],
(*A*)({x_, y_} -> "A"):> Sequence[{x, y + 1} -> "W", {x, y - 1} -> "S"],
(*S*)({x_, y_} -> "S"):> Sequence[{x - 1, y} -> "A", {x + 1, y} -> "D"],
(*D*)({x_, y_} -> "D"):> Sequence[{x - 1, y} -> "A", {x + 1, y} -> "D"],
(*Q*)({_, _} -> "Q") -> Sequence[]};
(*I used rules to implement bifurcation*)
(*I used WASD in place of NWSE to make typing code easier. The resulting structure
may only differ in their chirality, but in spirit the same.*)

(*converting level i of tree - tree[i] into graphics*)
Clear[convert];
convert[i_]:= Join[{Hue[Mod[i, 10]/10]},
tree[diagonal][i] /. x:{_Integer, _} :> Append[x, 2 i - 1] /. rule2,
tree[vertical][i] /. x:{_Integer, _} :> Append[x, 2 i - 1] /. rule3]

(*rule2 is about diagonal lines representing twigs*)
rule2 = {
(*W*)({x_, y_, z_} -> "W") :> Line[{{x, y, z}, {x, y - 1, z - 1}}],
(*A*)({x_, y_, z_} -> "A") :> Line[{{x, y, z}, {x + 1, y, z - 1}}],
(*S*)({x_, y_, z_} -> "S") :> Line[{{x, y, z}, {x, y + 1, z - 1}}],
(*D*)({x_, y_, z_} -> "D") :> Line[{{x, y, z}, {x - 1, y, z - 1}}]};

(*rule3 is about stems and fruit*)
rule3 = {
(*Q*)({x_, y_, z_} -> "Q") :> {color = Black, PointSize[0.03], Point[{x, y, z}]},
(*stems*)({x_, y_, z_} -> Except["Q"]) :> Line[{{x, y, z}, {x, y, z + 1}}]};


It take about 5+ minutes to iterate up to 50 times. (pattern matching being potentially exponential time?!)

tree[vertical][50(**)]


Each level graphed separately

Table[Graphics3D[convert[i], ViewPoint -> Top, BoxStyle -> Dashed], {i, 1, 50(**)}]


Altogether a rather intricate structure

Graphics3D[Flatten@Table[convert[i], {i, 1, 50(**)}] /.
PointSize[_] -> PointSize[0], ViewPoint -> Top, BoxStyle -> Dashed]


Easy to enumerate fruits (or twigs, omitted here)

Accumulate@Table[Count[tree[vertical][i], "Q", Infinity], {i, 1, 50}]

-
I think removing the r___ in your fruit checking rule should do the trick. Once sorted, the same coordinates should be adjacent in the list. No need to check every possible pair. – wxffles Jan 28 '13 at 22:16
Ho! This is unexpectedly simple. I wish I would grow to be as insightful into MMA code as that.^^ – 秦紀維 Jan 31 '13 at 11:27

Here's a code that seems a bit more in the functional-programming spirit of Mathematica. I divide the tree into active and inactive components to save time that might be wasted updating already-fruited branches. Then I can use a very simple rule to grow the tree. I use a Sow/Reap to quickly scan the tree for collided branches.

root={{},{{e},{w}}};

grow[{fruit_,tree_}]:={fruit,tree/.{{A___,b:(n|w)}:>Sequence@@{{A,b,n},{A,b,s}},{A___,b:(s|e)}:>Sequence@@{{A,b,e},{A,b,w}}}};

splitby[L_,f_]:=Split[SortBy[L,f],f[#1]==f[#2]&]

fruit[{fruit_,tree_}]:={Join[fruit,#2],#1}&@@(Flatten[#,2]&/@Reap[Sow[#,Length[#]]&/@splitby[tree,Sort[Tally[#]]&],{1,2}][[2]])

path[L_List]:={{0,0,0},{0,0,1}}~Join~Riffle[L/.{n->{0,1,1},s->{0,-1,1},e->{-1,0,1},w->{1,0,1}},{{0,0,1}}]~Join~{{0,0,1}}

show[T_]:=Graphics3D[{Darker[Brown],Tube[Accumulate[Most[path[#]]]&/@T[[1]]],Tube[Accumulate[path[#]]&/@T[[2]]],Red,Sphere[DeleteDuplicates[Total[Most[path[#]]]&/@T[[1,;;;;2]]],0.3]}]


The timing shows

Nest[fruit[grow[#]] &, root, 150]


takes about 4.5s on my machine, while your version (updated according to wxffles's) comment takes about 125s.

-
Somehow, trying merely to show[Nest[fruit[grow[#]] &, root, 30]] crash Mathematica 7 on my machine. Does this have something to do with the changed Graphic object properties, or it's just that I'm falling short of computational power? – 秦紀維 Jan 31 '13 at 11:14
Could be. I used 10 for testing purposes. Try changing Tube to Line and Sphere to Point to alleviate some of the graphical complexity. – Xerxes Jan 31 '13 at 22:46