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.

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}]
share|improve this question
    
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
add comment

1 Answer

up vote 4 down vote accepted

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.

share|improve this answer
    
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
add comment

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.