Re: Having trouble with substitution tile at higher iteration levels--> takes forever!

*To*: mathgroup at smc.vnet.net*Subject*: [mg55834] Re: Having trouble with substitution tile at higher iteration levels--> takes forever!*From*: rolf at mertig.com (Rolf Mertig)*Date*: Thu, 7 Apr 2005 05:10:24 -0400 (EDT)*References*: <d2tfkj$qnb$1@smc.vnet.net>*Sender*: owner-wri-mathgroup at wolfram.com

With a straightforward use of Split I can i=15 in about 16 minutes (on a fast Opteron machine). I am sure there must be a better way, but this is at least a slight improvement. Regards, Rolf Mertig GluonVision GmbH Berlin, Germany Mathematica 5.1 for Linux x86 (64 bit) Copyright 1988-2004 Wolfram Research, Inc. -- Motif graphics initialized -- In[1]:= !!b.m n = 3; p = 1; q = 2; r = 1; rule = NSolve[\[Lambda]^n - p*\[Lambda]^(n - 1) + q*\[Lambda] + r == 0, \[Lambda]][[3]]; phi[a] = b; phi[-a] = -b; phi[b] = c; phi[-b] = -c; phi[c] = Flatten[{Table[c, {p}], Table[-a, {r}], Table[-b, {q}]}]; phi[-c] = Flatten[{Table[b, {q}], Table[a, {r}], Table[-c, {p}]}]; SetAttributes[phi, Listable]; commutator[x_Symbol, y_Symbol] := Flatten[{x, y, -x, -y}]; commutator[x_Symbol, y_List] := Flatten[{x, y, -x, -Reverse[y]}]; commutator[x_List, y_Symbol] := Flatten[{x, y, -Reverse[x], -y}]; commutator[x_List, y_List] := Flatten[{x, y, -Reverse[x], -Reverse[y]}]; Block[{$DisplayFunction}, Timing[plt={}; result = Table[(AppendTo[plt, {i, #1}]; WriteString["stdout", "time used for ",i," ",#1,"\n"]; #2)& @@ Timing[ListPlot[FoldList[Plus, {0, 0}, FixedPoint[Function[z, Flatten[Split[z, #1 === -#2 & ] /. {_, _} :> Sequence[]] /. {{-(x_), m___, x_} :> {m}, {x_, m___, -(x_)} :> {m}}], Flatten[Nest[phi, commutator[b, c], i]]] /. a -> {1, 0} /. b -> {Re[\[Lambda]], Im[\[Lambda]]} /. c -> {Re[\[Lambda]^2], Im[\[Lambda]^2]} /. rule], PlotJoined -> True, Axes -> False]], {i, 1, 15} ]; plt ]] In[1]:= <<b.m time used for 1 0. Second time used for 2 0. Second time used for 3 0.000999 Second time used for 4 0.004 Second time used for 5 0.008999 Second time used for 6 0.025996 Second time used for 7 0.082988 Second time used for 8 0.253961 Second time used for 9 0.754886 Second time used for 10 2.36164 Second time used for 11 7.2389 Second time used for 12 22.1486 Second time used for 13 68.9565 Second time used for 14 213.916 Second time used for 15 666.384 Second Out[1]= {982.141 Second, {{1, 0. Second}, {2, 0. Second}, > {3, 0.000999 Second}, {4, 0.004 Second}, {5, 0.008999 Second}, > {6, 0.025996 Second}, {7, 0.082988 Second}, {8, 0.253961 Second}, > {9, 0.754886 Second}, {10, 2.36164 Second}, {11, 7.2389 Second}, > {12, 22.1486 Second}, {13, 68.9565 Second}, {14, 213.916 Second}, > {15, 666.384 Second}}} Roger Bagula <rlbagulatftn at yahoo.com> wrote in message news:<d2tfkj$qnb$1 at smc.vnet.net>... > This method was gotten by hard work from an article by Dr. Richard > Kenyon and gives a definition of a substitution tile as a boundary set. > It works fine until level nine. Level 12 has so far been impossible to > get. For some reason the rotation seems to work faster on my machine. > The reason higher levels are important to me is that the edges get > rougher and more factual as the level increases ( unlike the IFS > versions of fractal tiles). > It has been suggested that a step which eliminates {x,-x} symbol pairs > may be the process that is slowing it down by creating large string > chains that use much time and memory space. > I think we are lucky to have gotten as high a level output as we have at > i=11. > Any help in reducing the time to get a tile would be appreciated. > This tile and others are part of a project to bring tiling code to the > web where it can be utilized by more scholars. > Here's a text version ( conversion by 5.1): > A translation of > > "The Construction of Self-Similar Tiles", > > Richard Kenyon, into Mathematica > > Section 6 > > Specify the degree nâ?¥3 of the polynomial and the three integer > coefficients, pâ?¥0, qâ?¥0, râ?¥1, from the values he gives in Figure 7 page 17. > > n=3;p=1;q=2;r=1; > > Determine \[Lambda], the complex expansion coefficient, from the p,q,r > coefficients. > > > > rule=NSolve[\[Lambda]^n-p \[Lambda]^(n-1)+q \[Lambda]+ > > r\[Equal]0,\[Lambda]][[3]] > > \!\(\* > > RowBox[{\(General::"spell1"\), \(\(:\)\(\ \)\), "\<\"Possible spelling \ > > error: new symbol name \\\"\\!\\(rule\\)\\\" is similar to existing > symbol \\\ > > \"\\!\\(Rule\\)\\\". \\!\\(\\*ButtonBox[\\\"Moreâ?¦\\\", \ > > ButtonStyle->\\\"RefGuideLinkText\\\", ButtonFrame->None, \ > > ButtonData:>\\\"General::spell1\\\"]\\)\"\>"}]\) > > {\[Lambda]\[Rule]0.696323\[InvisibleSpace]+1.43595 \[ImaginaryI]} > > Create the mapping transformation rules from the definition of phi at > the top of page 16 in Kenyon's paper > > phi[a]=b;phi[-a]= -b;phi[b]=c;phi[-b]= -c; > > phi[c]=Flatten[{Table[c,{p}],Table[-a,{r}],Table[-b,{q}]}]; > > phi[-c]=Flatten[{Table[b,{q}],Table[a,{r}],Table[-c,{p}]}]; > > Make phi map across arguments of commutator > > SetAttributes[phi,Listable] > > Define the commutator of a pair of vectors as he defines in the middle > of page 16. > > > > > > commutator[x_Symbol,y_Symbol]:=Flatten[{x,y,-x,-y}]; > > commutator[x_Symbol,y_List]:=Flatten[{x,y,-x,-Reverse[y]}]; > > commutator[x_List,y_Symbol]:=Flatten[{x,y,-Reverse[x],-y}]; > > commutator[x_List,y_List]:=Flatten[{x,y,-Reverse[x],-Reverse[y]}]; > > Next we need to compose k copies of phi[] over these results for the k's > iteration. > > Nest[] does exactly what we want. > > > > Now let's see if it works, let's try to reproduce the tiles in Figure 8. > > > > > > Next take the word in the free group and replace every letter with the > numerical vector coordinates to make up the tile. > > Plot[] the resulting tile, as soon as everything is working and we have > the needed list of vectors. > > > > Notice how these start looking a little more like Figure 8 of Kenyon's > paper. > > > > Table[ListPlot[ > > FoldList[Plus,{0,0}, > > Flatten[Nest[phi,commutator[b,c], > > i]]//.{{h___,x_,-x_,t___}\[Rule]{h,t},{h___,-x_,x_, > > t___}\[Rule]{h,t},{-x_,m___,x_}\[Rule]{m},{x_, > > m___,-x_}\[Rule]{m}}/.a->{1,0}/.b->{Re[\[Lambda]], > > > Im[\[Lambda]]}/.c->{Re[\[Lambda]^2],Im[\[Lambda]^2]}/.rule], > > PlotJoined\[Rule]True,Axes\[Rule]False],{i,1,9}]; > > > > These tiles are rotated, to roughly match Kenyon's. > > <<Geometry`Rotations` > > Table[ListPlot[ > > FoldList[Plus,{0,0}, > > Map[Rotate2D[#,(i-1)Pi/2.8,{0,0}]&, > > Flatten[Nest[phi,commutator[b,c], > > i]]//.{{h___,x_,-x_,t___}\[Rule]{h,t},{h___,-x_,x_, > > t___}\[Rule]{h,t},{-x_,m___,x_}\[Rule]{m},{x_, > > > m___,-x_}\[Rule]{m}}/.a->{1,0}/.b->{Re[\[Lambda]], > > Im[\[Lambda]]}/.c->{Re[\[Lambda]^2], > > Im[\[Lambda]^2]}/.rule]],PlotJoined\[Rule]True, > > Axes\[Rule]False],{i,1,9}]; > > Here's a link to the notebook online. > http://f3.grp.yahoofs.com/v1/sI5RQv2ooF-hjsnEstJzYcUN8qnFAItN6APQvrmLWHM8gOfZgQSpqrR8rHpHSCbK_0QWRp8gEmnM77ZjPACVPw/Kenyon%20tile/tileKenyon_level9nopic.nb > Roger L. Bagula email: rlbagula at sbcglobal.net or > rlbagulatftn at yahoo.com > 11759 Waterhill Road, > Lakeside, Ca. 92040 telephone: 619-561-0814}