Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

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

• To: mathgroup at smc.vnet.net
• Subject: [mg55748] Having trouble with substitution tile at higher iteration levels--> takes forever!
• From: Roger Bagula <rlbagulatftn at yahoo.com>
• Date: Tue, 5 Apr 2005 03:21:30 -0400 (EDT)
• Sender: owner-wri-mathgroup at wolfram.com

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}