(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



(* ::Input::Initialization:: *)
(*Utilities*)
Once[<< KnotTheory`]
RotateToMinimal[l_]:=Module[
{bestl=l,rotatedl=RotateLeft[l]},
While[rotatedl=!=l,
bestl=First[Sort[{bestl,rotatedl}]];
rotatedl=RotateLeft[rotatedl]
];
bestl
];

SignX[c_X]:=If[PositiveQ[c],1,-1] (*determines sign of crossing*)
FindJointCrossing[pd_,m_,n_]:=(*Finds the unique?! crossing containing both m and n*)
Module[{Int},
Int=Intersection[#[[1]]&/@Position[pd,m],#[[1]]&/@Position[pd,n]];
If[Length[Int]==1,Int[[1]],If[Length[Int]==0,Pi,Print["WARNING:two or more crossings contain both m and n"]]]
]
FindJointCrossing2[pd_,m_,n_]:=(*Finds the unique?! crossing containing both m and n such that m,n are part of a cycle*)
Module[{Int,incycle=False},
Int=Intersection[#[[1]]&/@Position[pd,m],#[[1]]&/@Position[pd,n]];
If[Length[Int]==1,Int=Int[[1]];
If[SignX[pd[[Int]]]==-1,If[MemberQ[{Sort[{pd[[Int]][[2]],pd[[Int]][[3]]}],Sort[{pd[[Int]][[1]],pd[[Int]][[4]]}]},Sort[{m,n}]],incycle=True]];
If[SignX[pd[[Int]]]==1,
{Sort[{pd[[Int]][[1]],pd[[Int]][[2]]}],Sort[{pd[[Int]][[3]],pd[[Int]][[4]]}]};
If[MemberQ[{Sort[{pd[[Int]][[1]],pd[[Int]][[2]]}],Sort[{pd[[Int]][[3]],pd[[Int]][[4]]}]},Sort[{m,n}]],incycle=True]];
];
incycle

]


(* ::Input::Initialization:: *)
Knot2Bandtangle[pd_]:=Module[{cycles,bl,safety=0,treecrossings={},othercrossings,Garsides={},
caps={},bands,matchings,m},
cycles=(Times@@(pd /. X[i_,j_,k_,l_] :> If[PositiveQ@X[i,j,k,l], cyc[i,j]cyc[l,k],cyc[i,l]cyc[j,k]]))//.cyc[i_,m1___,j_]cyc[j_,m2___,k_]:>cyc[i,m1,j,m2,k] /. c_cyc:>RotateToMinimal@Most[c];
cycles=SortBy[List@@cycles,First];

bl=cycles;
Garsides={};
caps={};
While[Length[bl]>1&&safety<100,
safety++;
m=bl[[-1,1]];
treecrossings=Append[treecrossings,FindJointCrossing[pd,m,m-1]];
sign=SignX@pd[[FindJointCrossing[pd,m,m-1]]];
Garsides = Append[Garsides,Subscript[G, -sign][Sequence@@Reverse@Last@bl]];(*G for Garside*)
(*bl=Delete[bl,FirstPosition[bl,m-1]+{0,1}];*)
bl=Most[bl]/.m-1->Sequence@@Prepend[Reverse@Last@bl,m-1];
];
bl=Append[List@@(bl[[1]]),1];
othercrossings = Complement[Range@Length[pd],treecrossings];

bands=Table[If[FindJointCrossing2[Part[pd,othercrossings],bl[[i]],bl[[i+1]]],{bl[[i]],bl[[i+1]]},Nothing],{i,1,Length[bl]-1}];

matchings={FindJointCrossing[Part[pd,othercrossings],#[[1]],#[[2]]],-SignX@Part[Part[pd,othercrossings],FindJointCrossing[Part[pd,othercrossings],#[[1]],#[[2]]]]}&/@bands;
matchings=matchings/.{a_,b_}->Subscript[a,b];

Garsides=Sort/@(Garsides/.Thread[bl->Range@Length@bl]);
bf[FF_]:=Table[{FF[[i]],FF[[i+1]]},{i,1,Length[FF]-1}];
Garsides =(Subscript[G, #[[0,2]]]@@(bf@(List@@#)))&/@ Garsides;
bands=bands/.Thread[bl->Range@Length@bl];
Garsides =(Subscript[G, #[[0,2]]]@@(Intersection[(List@@#),bands]))&/@ Garsides;
Thread[bands->Range@Length@bands];
Garsides=Garsides/.Thread[bands->Range@Length@bands];
{Garsides,matchings}
]



(* ::Input::Initialization:: *)
(*A routine for visualizing our output. Green is positive, red negative. The boxes are Garsides (with half twists on each strand!)
The input is a list of Garsides with signs and a matching with signs. The color of the matching arcs denotes the sign of the half twist on that matching arc.*)
DrawTangle[{GG_,M_}]:=Graphics[{If[Length[#[[2]]]==2,{If[#[[1]]==1,Green,Red],BezierCurve[{{#[[2,1,1]],0},{(#[[2,1,1]]+#[[2,2,1]])/2,Abs[#[[2,1,1]]-#[[2,2,1]]]+1},{#[[2,2,1]],0}}]}
,Nothing]&/@Flatten[Table[{{1,Position[M,Subscript[i, 1]]},{-1,Position[M,Subscript[i, -1]]}},{i,Length[M]/2}],1],
Table[
{Table[Line[{{k,-i+1},{k,-i-1/3+1}}],{k,Length[M]}],
Table[Line[{{k,-i-2/3+1},{k,-i-1+1}}],{k,Length[M]}],
Table[Line[{{k,-i-1/3+1},{k,-i-2/3+1}}],{k,Complement[Range@Length[M],List@@GG[[i]]]}],
{If[GG[[i,0,2]]==1,Green,Red],Line[{{First@GG[[i]]-1/3,-i-1/3+1},{Last@GG[[i]]+1/3,-i-1/3+1},{Last@GG[[i]]+1/3,-i-2/3+1},{First@GG[[i]]-1/3,-i-2/3+1},{First@GG[[i]]-1/3,-i-1/3+1}}]}
}
,{i,Length[GG]}]
}
,ImageSize->Tiny]
(*and something to wrap a vector around for nicer display*)
WrapVectors[V_,H_,w_]:=Table[If[EvenQ[i],If[w i/2+j<=Length[V],V[[w i/2+j]]],If[w (i-1)/2+j<=Length[V],H[[w (i-1)/2+j]]]],{i,0,2Length[V]/w},{j,0,w}]



(* ::Input::Initialization:: *)
Garside2Braid[Gar_]:=Module[{sign=Gar[[0,2]],places=List@@Gar,ans},
{places,sign};
If[sign==-1,(*Also works if sign is positive but not 1*)
ans=Table[
X[c[places[[j+i]]]+j,c[places[[j]]]+j+i-1,c[places[[j+i]]]+j+1,c[places[[j]]]+j+i]
,{j,1,Length[places]-1},{i,1,Length[places]-j}],
ans=Table[
X[c[places[[j]]]+j+i-1,c[places[[j+i]]]+j+1,c[places[[j]]]+j+i,c[places[[j+i]]]+j]
,{j,1,Length[places]-1},{i,1,Length[places]-j}]
];
Flatten[ans,1]/.c[u_]->c[-u]
]
Garside2Braid[Subscript[G, -1][3,4]]
Garside2Braid[Subscript[G, -1][3,4,5]]


(* ::Input::Initialization:: *)
Garsides2Braid[Garsides_,Nstrands_]:=Module[{swapplaces,pd={},WG=Garsides,gars=0,currentG,bottomline=Range[Nstrands],halftwists=ConstantArray[0,Nstrands],s},
While[gars<100&&Length[WG]>0,
gars++;
currentG=First@WG;
swapplaces = List@@currentG;
(*Print["Garside2Braid[",currentG];*)
(*Garside2Braid[currentG];*)
pd = Join[pd,Garside2Braid[currentG]];

For[s=Min@swapplaces,s<=Max@swapplaces,s++,
pd=Subscript[m, s,-s->s][pd];
halftwists[[s]]=halftwists[[s]]+Sign[currentG[[0,2]]](*Careful the 1 in Subscript[G, 1] is affected by the replacement rule three lines down from here, hence Sign.*)
];
WG=(Rest@WG)/.Thread[swapplaces->Reverse[swapplaces]];
bottomline=bottomline/.Thread[swapplaces->Reverse[swapplaces]];
];
{pd,bottomline,halftwists}
]
Garsides2Braid[{Subscript[G, 1][3,4],Subscript[G, 1][7],Subscript[G, -1][2,3,4,5,6],Subscript[G, -1][1,2,3,4,5,6]},8]
Garsides2Braid[{Subscript[G, -1][2,3,4,5,6],Subscript[G, -1][1,2,3,4,5,6]},8]


(* ::Input::Initialization:: *)
Matching2Crossings[M_]:=Module[{counters=ConstantArray[0,Length[M]/2],WM,cur,pcur2,curcount,pair=0,pd={}},
(*First rename the elements of M so that they are all in 1,2,..LengthM/2, output is with negative strand names.*)
counters;
WM=M/.Thread[DeleteDuplicates[M]->Range[Length[M]/2]];
While[pair<100&&Length[WM]>0,(*WM is a copy of M from which we keep removing pairs, starting with the leftmost*)
pair++;
(*Print["pair= ",pair];*)
cur=WM[[1]];(*The current symbol to work with*)
(*Print["cur= ",cur];*)
pcur2=Position[WM,cur][[2,1]];
(*Print["pcur2= ",pcur2];*)
curcount=0;
Table[
(*Print["i= ",i," WM[i]= ",WM\[LeftDoubleBracket]i\[RightDoubleBracket]];*)
If[Position[WM,WM[[i]]][[2,1]]>pcur2,
pd=Append[pd,X[c[-WM[[i]]]+counters[[WM[[i]]]]-1,c[-cur]+curcount+1,c[-WM[[i]]]+counters[[WM[[i]]]],c[-cur]+curcount]];
counters[[WM[[i]]]]--;curcount++;
];

,{i,2,pcur2-1}];
WM=DeleteCases[WM,cur];
];
(*Shift the crossing labels so that each component c[i] starts with c[i]+1 and then c[i]+2...*)

pd=pd/.Table[
Module[{cas},cas=Cases[pd/.{X->List}//Flatten//Sort,c[i]+u_]/.c[i]->0;
If[Length[cas]>0,c[i]->c[i]-If[First@cas<0,First@cas,0],Nothing]
],
{i,-1,-Length[M]/2,-1}
];
pd/.Table[c[i]->c[i]+1,{i,-1,-Length[M]/2,-1}]
];
Matching2Crossings[{a,f,e,b,c,f,c,b,d,e,a,d}]


(* ::Input::Initialization:: *)
Subscript[LenComp, comp_][pd_]:=Module[{Cas},Cas=Cases[pd/.{X->List}//Flatten,c[comp]+u_]/.c[comp]->0;If[Length[Cas]>0,Max@Cas,1]](*Empty components have length 1!*)


(* ::Input::Initialization:: *)
Subscript[Flip, i_][X[p_,q_,r_,s_]]:=Module[{},If[Coefficient[p,c[i]]==1,X[r,s,p,q],X[p,q,r,s]]];(*To reverse we need to flip the order of the half edges around the crossing if we reverse the understrand,
careful: renumbering below flips p and r again in the underpass case.
We call the reversal function S for antipode but note it is the involutory one!*)
Subscript[S, comp_][PDin_]:=Module[{lencomp,u,pd=PDin},(*Are kinks reversed properly?? Assuming strand is not closed!*)
lencomp=Subscript[LenComp, comp][pd];
pd=pd/.{c[comp]+u_->c[comp]+lencomp+1-u};
Subscript[Flip, comp]/@pd
]
Subscript[S, 1r][{X[c[5]+1,2+c[3],2+c[5],1+c[3]],X[c[6]+1,3+c[3],2+c[6],2+c[3]],X[3+c[1 r],4+c[3],4+c[1 r],3+c[3]],X[2+c[1 r],2+c[4],3+c[1 r],1+c[4]],X[1+c[1 r],2+c[2],2+c[1 r],1+c[2]]}]


(* ::Input::Initialization:: *)
(*Stitching is traditionally called m, Assuming strands are not closed!*)
Clear[m];
Subscript[m, comp1_,comp2_->newname_][pdin_]:=Module[{pd=pdin,lencomp1},
(*Print["Stitching ",comp1," ",comp2];*)
lencomp1=Subscript[LenComp, comp1][pd];
pd=pd/.{c[comp2]->c[newname]+lencomp1-1};
pd=pd/.c[comp1]->c[newname]
]


(* ::Input::Initialization:: *)
ConstructExplicitTangle[{Garsides_,Matchings_}]:=Module[{L=Length[Matchings],bottomline,pd,curmatchpos1,curmatchpos2,matchcomp,Wbot,safety=0,curS,halftwists,bottomends},
{pd,bottomline,halftwists}=Garsides2Braid[Garsides,L];
Wbot=bottomline;
bottomends=bottomline;
pd=Join[pd,Matching2Crossings[Matchings]];
While[safety<100&&Length[Wbot]>0,
safety++;
curS = First@Wbot;
pd = Subscript[S, curS][pd];
halftwists[[curS]]=halftwists[[curS]]+Matchings[[curS]][[2]];halftwists;
{{curmatchpos1},{curmatchpos2}}=Position[Matchings,Matchings[[curS]]];
matchcomp =-Length[Union@Matchings[[1;;curmatchpos1]]];
If[curmatchpos1==curS,
(*Print["No reverse"];*)
pd=Subscript[m, curS,matchcomp->curS][pd];
pd=Subscript[m, curS,curmatchpos2->curS][pd];
bottomends=bottomends/.curmatchpos2->curmatchpos1;
,
(*Print["Reverse"];*)
pd=Subscript[S, matchcomp][pd];
pd=Subscript[m, curS,matchcomp->curS][pd];
pd=Subscript[m, curS,curmatchpos1->curS][pd];
bottomends=bottomends/.curmatchpos1->curmatchpos2;
];
(*turn halftwists into kinks and add them*)
If[halftwists[[curmatchpos1]]+halftwists[[curmatchpos2]]>0,
pd = Join[pd,
Table[X[c[1/2]+2+2i,c[1/2]+2+2i,c[1/2]+3+2i,c[1/2]+1+2i]
,{i,0,Abs[halftwists[[curmatchpos1]]+halftwists[[curmatchpos2]]]/2-1}]];,
pd = Join[pd,
Table[X[c[1/2]+1+2i,c[1/2]+2+2i,c[1/2]+2+2i,c[1/2]+3+2i]
,{i,0,Abs[halftwists[[curmatchpos1]]+halftwists[[curmatchpos2]]]/2-1}]];
];
pd=Subscript[m, curS,1/2->curS][pd];
Wbot= DeleteCases[Wbot,curmatchpos1|curmatchpos2];
];
{pd,bottomends}
]
ConstructExplicitTangle@Knot2Bandtangle[PD@Knot[8,20]]
%/.X->List//Flatten//Sort
%//BinCounts


(* ::Input::Initialization:: *)
(*DoubleAll doubles all strand of a tangle, it uses the auxilliary function Reparametrize*)
Reparametrize[pd_]:=Module[{wpd=pd/.X->List//Flatten,comps,rules,len,ans},
comps=wpd/.c[u_]+v_->c[u]//Union;
rules=Flatten@Table[
len=Length[Cases[wpd,co+u_]//Union];
Thread[(Cases[wpd,co+u_]//Union)->Table[co+i,{i,len}]]
,{co,comps}];
pd/.rules
 ]
DoubleAll[pd_]:=Reparametrize[Flatten[pd/.{X[p_,q_,r_,s_]->If[PositiveQ@X[p,q,r,s],
{X[Subscript[p, L],Subscript[(s+1/2), R],Subscript[(p+1/2), L],Subscript[s, R]],X[Subscript[p, R],Subscript[q, R],Subscript[(p+1/2), R],Subscript[(s+1/2), R]],X[Subscript[(p+1/2), L],Subscript[(s+1/2), L],Subscript[r, L],Subscript[s, L]],X[Subscript[(p+1/2), R],Subscript[q, L],Subscript[r, R],Subscript[(s+1/2), L]]},{X[Subscript[p, R],Subscript[q, L],Subscript[(p+1/2), R],Subscript[(q+1/2), L]],X[Subscript[(p+1/2), R],Subscript[q, R],Subscript[r, R],Subscript[(q+1/2), R]],X[Subscript[p, L],Subscript[(q+1/2), L],Subscript[(p+1/2), L],Subscript[s, L]],X[Subscript[(p+1/2), L],Subscript[(q+1/2), R],Subscript[r, L],Subscript[s, R]]}
]},1]/.Subscript[(c[u_]+w_), v_]->c[u v]+w]
(ConstructExplicitTangle@Knot2Bandtangle[PD@Knot[8,20]])[[1]]//DoubleAll
%/.X->List//Flatten//Sort


(* ::Input::Initialization:: *)
(*This turns the output of ConstructExplicitTangle into a pd code of a knot by thickening it in the standard way and then stitching in the order given by how the feet of the tangle meet the bottom.*)
ThickenTangle[pdTangle_,bottom_]:=Module[{pd=pdTangle,bot=bottom,strand,Li,Liold},
(*Shift the names of the components by 1 to avoid annoying bugs with 1R = R and 1L = L*)
bot=bot+1;
pd=pd/.{c[u_]->c[u+1]};
strand=bot//DeleteDuplicates;
pd=DoubleAll[pd];
(*pd/.X\[Rule]List//Flatten//Sort//Echo;*)
For[i=1,i<=Length[bot]/2,i++,
pd=pd//Subscript[S, strand[[i]]*R]
];
(*pd/.X\[Rule]List//Flatten//Sort//Echo;*)
Li=Table[If[{j}==FirstPosition[bot,bot[[j]]],{L bot[[j]],bot[[j]] R},{R bot[[j]],bot[[j]] L}],{j,1,Length[bot]}];
For[i=1,i<=Length[Li]-1,i++,
pd=pd//Subscript[m, Li[[i,2]],Li[[i+1,1]]->Li[[i+1,1]]];
Li=Li/.Li[[i,2]]->Li[[i+1,1]];
];
pd=pd/.Subscript[LenComp, Li[[1,2]]][pd]->1;(*close the loop*)
pd = pd/.{c[u_]->0}
]
ThickenTangle@@ConstructExplicitTangle@Knot2Bandtangle[PD@Knot[8,20]]
%/.X->List//Flatten//Sort


(* ::Input::Initialization:: *)
(*Simple slow Kauffman bracket routine from KnotAtlas website, fancy Jones doesnt work!*)
KB0[pd_]:=Expand[Expand[Times@@pd/.X[a_,b_,c_,d_]:>A P[a,d] P[b,c]+1/A P[a,b] P[c,d]]//.{P[a_,b_]P[b_,c_]:>P[a,c],P[a_,b_]^2:>P[a,a],P[a_,a_]->-A^2-1/A^2}]
ShiftLaurent[P_]:=P*A^-Exponent[P,A]/Coefficient[P,A^Exponent[P,A]]//Expand
KBshifted[pd_]:=KB0[pd]//ShiftLaurent;



(* ::Input::Initialization:: *)
TestKnotJones[K_]:=
Jones[Echo[PD@@ThickenTangle@@ConstructExplicitTangle@Knot2Bandtangle[PD@K]]][t]==Jones[PD@K][t]
TestKnotAlex[K_]:=
Alexander[PD@@ThickenTangle@@ConstructExplicitTangle@Knot2Bandtangle[PD@K]][t]==Alexander[PD@K][t]



