(*
* This package will generate the graph of a template, based on two
* strings of information. The first is the weaving array, a list of
* positive or negative integers. Each integer i refers to a crossing
* between the ith and (i+1)-st branch of the template (the branches are
* numbered beginning at 1). Positive i refers to a positive, or
* right-hand crossing, and negitive i to a negative, or left-hand
* crossing. There is no need to list 0 or any other default for branches
* which do not cross.
* The second string of information is the framing array, also a list of
* positive or negative integers. Again, the sign of each element of the string
* refers, in the standard way, to the direction of the twist. However, the
* position of the element in the string determines the branch to which it
* refers and the value of the element refers to the number of twists. Each
* branch must have an entry in the framing array. The default is 0 for no
* twists.
* The knotplot function assumes that the input words are of prime period, ie
* they cannot be written as words of any lesser period. Sigmas and torsion
* lists are assumed to be global. Given some previously defined template and a
* list of words (i.e. {{0},{1},{0,1}} ), the knotplot options are:
* 1) knotplot[{{0},{1},{0,1}}]
* This graphs the template and the words, without connections from the
* bottom to the top of the template.
* 2) knotplot[{{0},{1},{0,1}},true]
* This graphs the template, the words and the connections.
*)
(*DEFAULT TEMPLATE*) sigmas={};torsion={0,0,0,0,0,0,0,0,0,0};
bcolor[0]:= RGBColor[0.000, 0.000, 0.000];(*black*)
bcolor[6]:= RGBColor[1.000, 0.586, 0.951];(*pink*)
bcolor[9]:= RGBColor[0.611, 0.318, 1.000];(*blue-purple*)
bcolor[5]:= RGBColor[1.000, 0.721, 0.072];(*maze*)
bcolor[4]:= RGBColor[1.000, 0.069, 0.107];(*red*)
bcolor[2]:= RGBColor[0.481, 0.658, 1.000];(*cornflower*)
bcolor[10]:=RGBColor[0.116, 0.658, 0.038];(*green*)
bcolor[7]:= RGBColor[0.824, 0.105, 1.000];(*purple*)
bcolor[8]:= RGBColor[1.000, 0.308, 0.066];(*red-orange*)
bcolor[1]:= RGBColor[0.133, 0.697, 1.000];(*mid blue*)
bcolor[3]:= RGBColor[1.000, 0.899, 0.216];(*brighter yellow*)
Template[sigmas_List,torsion_List,word_List,connectQ_]:=
Block[{height,branch,cl,branches,
torlen,siglen,outline,
perbranch,origword,
origbr,knitting},
torlen=Length[torsion];
siglen=Length[sigmas];
branch=torlen;
height=siglen+Max[Abs[torsion]];
cl={1,2,3,4,5,6,7,8,9,10};
branches=Table[i,{i,branch}];
outline=Thickness[.01];
If[word=={},origword={},
knitting=Knotting[word,branch];
origword=knitting[[1]]; (*a per-word list of position coordinates*)
origbr=knitting[[2]]; (*the original per-branch list of coords*)
perbranch=origbr; (*a running list of per-branch coords*)
];
Return[{TFrame[torsion,height],Weave[sigmas,branch],
Insertion[branch,connectQ]}]
]
Weave[sigmas_List,branch_]:= (*for each entry i in the sigmas list*)
Block[ {j, (*crosses i and i+1, then extends the rest*)
branchlist,weavelist={},restlist},
branchlist=Table[i,{i,branch}];
level=Length[sigmas];
Do[
AppendTo[weavelist, Apply[Sigma,{sigmas[[j]],level}]];
PermCl[ Abs[sigmas[[j]]] ];
Extend[i_]:=Extend[i,level];
restlist=Drop[branchlist, {Abs[ sigmas[[j]] ],Abs[ sigmas[[j]] ]+1}];
AppendTo[weavelist, Map[Extend,restlist]];
level--, {j,Length[sigmas]}
];
Return[weavelist]
]
TFrame[torsion_List,toplevel_]:= (*twists each branch in the appropriate*)
Block[ {i,j, (*direction, then adds or subtracts 1 from*)
level, (*the torsion list unless and untill the *)
twists={},twistlist}, (*entries are 0*)
twistlist=torsion;
level=toplevel;
While[ Apply[Plus, Abs[twistlist]]!=0,
Do[ If[twistlist[[i]]==0,
AppendTo[twists, Extend[i, level]],
AppendTo[twists, Twist[Sign[twistlist[[i]]]*i,level]]
],
{i,Length[twistlist]}];
Do[ If[twistlist[[j]]!=0,
twistlist[[j]]=twistlist[[j]]-Sign[twistlist[[j]]]
], {j,Length[twistlist]}
];
level--;
];
Return[twists]
]
Sigma[i_,level_]:= (*distinguishes between positive and negative crosses*)
Which[i>=0, Cross[i,i+1,level],
True, Cross[-i+1,-i,level]
]
Insertion[b0_,connectQ_]:=
Block[ {blist={},
i,b,num,points,level=0},
b=2*b0-1;
For[i=1,i<=b0,i++,
num=branchnum[i];
points=Flatten[{cosline[0,num,level],
cosline[b,num+1,level]},1];
AppendTo[blist,
{bcolor[cl[[i]]],
Polygon[points],
bcolor[0],outline,
Line[points],Knit[i,inj,level]}]
];
If[connectQ==True,AppendTo[blist,TConnect[height+1,b]]];
Return[Flatten[blist,1]]
]
Cross[i_,j_,level_]:=
Block[ {inum,jnum,ipoints,jpoints,ilines,jlines},
inum=branchnum[i];
jnum=branchnum[j];
If[ix1, costab[x0,x1,level],
True, Reverse[costab[x0,x1,level]]
]
costab[x0_,x1_,level_]:=Block[{k,n=11},Return[Table[
{((Cos[(Pi*k)/n//N]-1)((x0-x1)/2))+x0,
level+ k/n//N},
{k,0,n}]]]
branchnum[i_]:=2(i-1) (*x-coord of left edge of the ith branch*)
grTemplate[sigmas_List,torsion_List]:= (*graphs template*)
Show[Graphics[Template[sigmas,torsion,{},False],AspectRatio->Automatic]]
knotplot[wd_List]:= (*graphs template (previousely defined) and words*)
Show[Graphics[Template[sigmas,torsion,wd,False],AspectRatio->Automatic]]
knotplot[wd_List,Contrue_]:= (*graphs template and words, with connects*)
Show[Graphics[Template[sigmas,torsion,wd,True],AspectRatio->Automatic]]
kcolor[3]:= RGBColor[0.990, 1.000, 0.602];(*yellow*)
kcolor[2]:= RGBColor[0.578, 1.000, 0.622];(*light green*)
kcolor[6]:= RGBColor[0.641, 1.000, 0.923];(*very light blue*)
kcolor[1]:=RGBColor[0.658, 0.703, 1.000];(*light blue*)
kcolor[7]:= RGBColor[0.967, 0.718, 1.000];(*light pink*)
kcolor[8]:= RGBColor[1.000, 0.662, 0.516];(*light brownish*)
kcolor[10]:= RGBColor[0.426, 0.603, 1.000];(*darker blue*)
kcolor[4]:= RGBColor[0.684, 1.000, 0.350];(*green*)
kcolor[9]:= RGBColor[1.000, 0.468, 0.833];(*pink*)
kcolor[5]:= RGBColor[0.619, 0.449, 1.000];(*purple*)
Knit[br_,kind_,level_]:=Knit[br,kind,level,False]
Perbr[i_]:=perbranch[[branches[[i]]]]
Knit[br_,kind_,level_,crosscheck_]:=
Block[ {kfrom,kto,i,j,len,lines={},
width,relbr,temp,crossbr=0},
If[origword=={},Return[{}]];
kfrom=Perbr[br];
Which[kind==rcross,crossbr=br,
kind==lcross,crossbr=br-1];
If[kfrom=={},
If[crosscheck,PermBr[crossbr]
];Return[{}]
];
width=Thickness[.01];
len=Length[kfrom];
relbr=branches[[br]];
Which[kind==inj,
temp=listRepl[inj,relbr];kto=temp[[relbr]],
True,
perbranch=listRepl[kind,relbr];kto=Perbr[br]
];
tie[i_]:=
{kcolor[GetColor[br,i]],
Line[cosline[kto[[i]],kfrom[[i]],level]]};
lines=Array[tie,len];
PrependTo[lines,width];
If[crosscheck,PermBr[crossbr]];
Return[Flatten[lines]]
]
Knotting[wd_List,branch_]:=
Block[ {prepared,period,orgwd,
perbr={},temp={},
i,j,k,num,len,many,divs},
period=Apply[LCM,Map[Length,wd]];
orgwd=Prepare[wd,period];
prepared=Sort[Flatten[orgwd]];
j=0;
num=branch^(period-1);
findivs[e_]:=Quotient[e,num]==j;
For[i=1,i<=branch,i++,
AppendTo[temp,Select[prepared, findivs]];
j++
];
len=Length[temp];
For[i=1,i<=len,i++,
many=Length[temp[[i]]];
divs=BrDivisions[many,i];
AppendTo[perbr,divs];
For[k=1,k<=many,k++,
orgwd=orgwd/. temp[[i,k]]->divs[[k]];
]
];
Return[{orgwd,perbr}]
]
Pairity[branch_]:=
Which[Mod[torsion[[branch]],2]==0,1,
True,-1]
InduceOrder[wd_List,b_]:= (*takes word and creates new word*)
Block[ {wdmap={},wdadd, (*according to kneading sequence*)
i,j,len,partsum},
If[Depth[wd]>2,Return[Map[InduceOrder,wd]]];
wdadd=wd+1;
len=Length[wdadd];
For[i=1,i<=len,i++,
partsum=Product[Pairity[wdadd[[j]]],{j,i-1}];
AppendTo[wdmap,
Which[partsum>=0, wdadd[[i]],
True, (b+1)-(wdadd[[i]])]]
];
Return[wdmap-1]
]
NaryTrans[wd_List,b_]:= (*translates N-ary sequence into decimel*)
Block[ {i,len},
If[Depth[wd]>2,Return[Map[NaryTrans,wd]]];
len=Length[wd];
Return[Sum[wd[[i]]*b^(len-i),{i,len}]]
]
ExtendWd[wd_List,lcm_]:=
Block[ {i,expwd={}},
For[i=1,i<=Length[wd],i++,
AppendTo[expwd,Flatten[Table[wd[[i]],
{lcm/Length[wd[[i]]]}]]]
];
Return[expwd]
]
ExtendWd[wd_]:=ExtendWd[wd,period];
InduceOrder[wd_]:=InduceOrder[wd,branch];
NaryTrans[wd_]:=NaryTrans[wd,branch];
Prepare[wd_List,lcm_]:= (*takes original list*)
Block[ {wdperm,wdext,wdind,wdtrans,period},
period=lcm;
wdperm=Map[Cyc,wd];
wdext=Map[ExtendWd,wdperm];
wdind=Map[InduceOrder,wdext];
wdtrans=Map[NaryTrans,wdind];
Return[wdtrans]
]
Cyc[wd_]:=NestList[RotateLeft,wd,Length[wd]-1]
listRepl[kind_,br_]:=
Block[ {lc,rc},
lc[x_]:=x-2;
rc[x_]:=x+2;
Which[kind==twist, MapAt[Reverse,perbranch,{{br}}],
kind==rcross, MapAt[rc,perbranch,{{br}}],
kind==lcross, MapAt[lc,perbranch,{{br}}],
kind==inj, MapAt[injmap,perbranch,{{br}}],
kind==extend, perbranch
]
]
injmap[wd_List]:=Map[GetInj,wd]
BrDivisions[manybr_,whatbr_]:= (*takes list of int. per branch and*)
Block[ {len,i,offset, (*# of branch and returns coords. Assumes*)
num,coords={}}, (*list in order*)
If[manybr==0,Return[{}]];
num=branchnum[whatbr];
offset=1/(2*manybr);
div[j_]:=(j/manybr)-offset+num;
Return[Array[div,manybr]]
]
GetInj[a_]:=
Block[ {pos,camefrom,wdpos,mapto},
pos=Flatten[Position[perbranch,a]];
camefrom=origbr[[pos[[1]],pos[[2]]]];
wdpos=Flatten[Position[origword,camefrom]];
mapto=Map[RotateLeft,origword][[wdpos[[1]],wdpos[[2]]]];
Return[mapto]
]
GetColor[br_,i_]:=
Block[ {pos,place},
pos=origbr[[branches[[br]],i]];
place=Flatten[Position[origword,pos]][[1]];
Return[place]
]
PermCl[a_]:=
Block[ {temp},
temp=cl[[a+1]];
cl[[a+1]]=cl[[a]];
cl[[a]]=temp
]
PermBr[a_]:=
Block[ {temp},
temp=branches[[a+1]];
branches[[a+1]]=branches[[a]];
branches[[a]]=temp
]
PermPerBr[a_]:=
Block[ {temp},
temp=perbranch[[a+1]];
perbranch[[a+1]]=perbranch[[a]];
perbranch[[a]]=temp
]
SemCirc[knot_,point_]:=
Block[ {G,H,r,circ,dist},
dist=point-knot;
r=dist/2;
G[x_]:=(-1)*Sqrt[(2*r-x+knot) (x-knot)];
H[i_]:={knot+((i-1)/16)*(dist),G[knot+((i-1)/16)*(dist)]};
circ=Array[H,17];
Return[circ]
]
Connections[knot_,point_,height_]:=
Block[ {semi,flip,raise},
semi=SemCirc[knot,point];
flip=Map[#*{1,-1}&,semi];
raise=Reverse[Map[#+{0,height}&,flip]];
Return[Flatten[{semi,raise},1]]
]
Corridor[width_,num_]:=
Block[ {R},
R[i_]:=(width+1)+i*(2/num)-(1/num);
Return[Reverse[Array[R,num]]]
]
TConnect[height_,width_]:= (*assume origbr, origword- global*)
Block[ {num,flatword,flatbr,points,colors,F,thick},
If[origword=={},Return[{}]];
flatword=Flatten[origword];
flatbr=Flatten[origbr];
num=Length[flatword];
thick=Thickness[.01];
points=Corridor[width,num];
colors=Map[Flatten[Position[origword,#],1][[1]]&, flatword];
F[i_]:=
Block[ {pos,knot,point},
knot=flatword[[i]];
pos=Flatten[Position[flatbr,knot]];
point=points[[pos[[1]]]];
Return[{thick,kcolor[colors[[i]]],
Line[Connections[knot,point,height]]}]
];
Return[Array[F,num]]
]
(* Examples:
* sigmas={};torsion={0,1};
* grTemplate[{},{0,1}]
* knotplot[{{0},{1},{0,1},{1,1,0}}]
* knotplot[{{0},{0,1},{1,0,0}},True]
*)