KhBraids

October 2014, Scott Morrison, Anthony Licata, Hannah Keese and Hilary Hunt

KnotTheoryPaths={"/Users/scott/projects/KnotTheory/trunk/","/Users/tony/Desktop/"}
$Path=$Path~Join~KnotTheoryPaths;
<<KnotTheory`

Code

NumberOfCrossings[b_BR]:=Length[SignsOfCrossings[b]] (* Returns the number of crossings in the braid *)

SignsOfCrossings[b_BR]:=(* return a list of +1 and -1s, indicating the signs of the crossings *)
Sign/@(b[[2]])

(* Generates a list of the resolutions of the braid *)
CubeOfResolutions[braid_BR]:=CubeOfResolutions[braid]=Module[
{types,
circles,
cube},
types=ResolutionTypes[braid];
Resolution[braid,#]&/@types
];

(* Checks that a resolution is valid *)
VerifyResolution[r:Resolution[braid_BR,type:{(0|1)...},circles_]]:=If[!MemberQ[CubeOfResolutions[braid],r],
Print["Someone tried to construct an invalid resolution: ",r];Abort[],
r
]

(* Completes type Resolution with a list of circles found in the resolution *)
Resolution[braid_BR,type:{(0|1)...}]:=Resolution[braid,type,
ResolutionCircles[braid,type]
]

(* Returns a list of the resolution types found in the cube of resolutions of braid *)
ResolutionTypes[braid_BR]:=Module[
{length,
typeArray},
length=NumberOfCrossings[braid];
typeArray=Tuples[{0,1},length]
];

productToList[X_Times]:=List@@X
productToList[X_]:={X}

(* Generates the list of circles found in a specific resolution of braid *)
ResolutionCircles[braid_BR,type:{(0|1)...}]:=ResolutionCircles[braid,type]=Module[
{braidList=braid[[2]],
product,
i,j,k,
R,S,z,
JoinLines1,JoinLines2,JoinLines3,
makeCircle},
SetAttributes[S,Orderless];
product=Product[
R[{4*i+2-type[[i+1]]},
S[z[i,Abs[braidList[[i+1]]]-1],z[i+1-type[[i+1]],type[[i+1]]+Abs[braidList[[i+1]]]-1]]]*R[{4*i+4-type[[i+1]]},
S[z[i+type[[i+1]],Abs[braidList[[i+1]]]-type[[i+1]]],z[i+1,Abs[braidList[[i+1]]]]]]*Product[(S[z[i,j],z[i+1,j]]),{j,Complement[Range[braid[[1]]]-1,Abs[braidList[[i+1]]]+{-1,0}]}],{i,0,Length[braidList]-1}]*Product[R[{4*Length[braidList]+1+k},S[z[Length[braidList],k],z[0,k]]],{k,0,braid[[1]]-1}];
(*Print[TableForm[List@@product]];*)
S/:S[a_,b_]S[b_,c_]:=S[a,c];
R/:R[g_,S[a_,b_]]S[b_,c_]:=R[g,S[a,c]];
R/:R[g_,S[a_,b_]]R[h_,S[b_,c_]]:=R[Join[g,h],S[a,c]];
makeCircle=R[g_,_]:>g;
Map[Sort,productToList[product]/.makeCircle]
];

constructBasisVector[r_Resolution,signs_]:=BasisVector[VerifyResolution[r],Sort[signs]]

(* Returns a list of the basis vectors found in a resolution *)
BasisVectors[r_Resolution]:=BasisVectors[r]=Module[{numberOfCircles=Length[r[[3]]]},
constructBasisVector[r,Thread[r[[3]]->#]]&/@Tuples[{-1,+1},numberOfCircles]
]

HomologicalGrading[b_BasisVector]:=HomologicalGrading[b[[1]]]

HomologicalGrading[r_Resolution]:=HomologicalGrading[r]=
(* 0 resolutions contribute 0 to the homological grading *)
(* 1 resolutions contribute +/- 1 to the homological grading, depending on the sign of the crossing *)
SignsOfCrossings[r[[1]]].r[[2]]

HomologicalGrading[α_Integer b_BasisVector]:=HomologicalGrading[b]
HomologicalGrading[X_Plus]:=Module[{gradings},
gradings=Union[HomologicalGrading/@(List@@X)];
If[Length[gradings]≠1,Print["Tried to compute the homological grading of a non-homogeneous element: ",X];Abort[],
gradings[[1]]
]
]

EulerGrading[b_BasisVector]:=EulerGrading[b]=
(* 0 resolutions of +ve crossings give +1 *)
(* 1 resolutions of +ve crossings give +2 *)
(* 0 resolutions of -ve crossings give -1 *)
(* 1 resolutions of -ve crossings give -2 *)
SignsOfCrossings[b[[1,1]]].(b[[1,2]]+1)+(Plus@@b[[2,All,2]])

EulerGrading[α_Integer b_BasisVector]:=EulerGrading[b]
EulerGrading[X_Plus]:=Module[{gradings},
gradings=Union[EulerGrading/@(List@@X)];
If[Length[gradings]≠1,Print["Tried to compute the Euler grading of a non-homogeneous element: ",X];Abort[],
gradings[[1]]
]
]

basePointArc[resolution_]:=Range[resolution[[1]][[1]]]+4*Length[resolution[[1]][[2]]]

AnnularGrading[BasisVector[resolution_,signs_]]:=AnnularGrading[BasisVector[resolution,signs]]=Module[{},
Plus@@(Cases[signs,(circle_->sign_)/;CircleEssentialQ[basePointArc[resolution],circle]][[All,2]])
]

AnnularGrading[X_Times]:=Plus@@AnnularGrading/@(List@@X)
AnnularGrading[((X_)^(k_))]:=k AnnularGrading[X]
AnnularGrading[z_Integer]:=0
AnnularGrading[X_Plus]:=Module[{gradings},
gradings=Union[AnnularGrading/@(List@@X)];
If[Length[gradings]≠1,Print["Tried to compute the annular grading of a non-homogeneous element: ",X];Print[gradings];Abort[],
gradings[[1]]
]
]

CircleEssentialQ[basePointArc_,circle_]:=Mod[Length[Intersection[basePointArc,circle]],2]==1

Bigrading[X_]:={HomologicalGrading[X],EulerGrading[X]}

AllHomologicalGradings[b_BR]:=AllHomologicalGradings[b]=Union[HomologicalGrading/@CubeOfResolutions[b]]
AllEulerGradings[b_BR]:=AllEulerGradings[b]=Union[EulerGrading/@AllBasisVectors[b]]
AllAnnularGradings[b_BR]:=AllAnnularGradings[b]=Union[AnnularGrading/@AllBasisVectors[b]]

AllBigradings[b_BR]:=AllBigradings[b]=Union[{HomologicalGrading[#],EulerGrading[#]}&/@AllBasisVectors[b]]

LeeDifferentialForCrossing[k_Integer][b_BasisVector]:=Module[
{image,
newCircles,newCirclesPos,
oldCircles,oldCirclesPos,
sign},
If[(SignsOfCrossings[b[[1,1]]][[k]]==-1&&b[[1]][[2]][[k]]==0)||(SignsOfCrossings[b[[1,1]]][[k]]==1&&b[[1]][[2]][[k]]==1),
0,
sign=(-1)^(Plus@@Take[b[[1]][[2]],k-1]);
image=Resolution[b[[1]][[1]],ReplacePart[b[[1]][[2]],k->1-b[[1]][[2]][[k]]]];
newCircles=Complement[image[[3]],b[[1]][[3]]];
oldCircles=Complement[b[[1]][[3]],image[[3]]];
sign*If[Length[newCircles]==1,
MergingDifferential[k][b][newCircles,oldCircles,image],
SplittingDifferential[k][b][newCircles,oldCircles,image]]]
];

(* Applies the splitting differential to a basis vector *)
SplittingDifferential[k_Integer][b_BasisVector][newCircles:{_List,_List},oldCircles:{_List},image_Resolution]:=Module[
{oldSigns,
newSign,
newSigns,
newSigns1,newSigns2},
oldSigns=oldCircles/.b[[2]];
newSigns1=newSigns2=DeleteCases[b[[2]],(circle_->value_)/;MemberQ[oldCircles,circle]];
If[oldSigns=={-1},
AppendTo[newSigns1,newCircles[[1]]->-1];
AppendTo[newSigns1,newCircles[[2]]->-1];
AppendTo[newSigns2,newCircles[[1]]->1];
AppendTo[newSigns2,newCircles[[2]]->1];
constructBasisVector[image,newSigns1]+constructBasisVector[image,newSigns2],

AppendTo[newSigns1,newCircles[[1]]->1];
AppendTo[newSigns1,newCircles[[2]]->-1];
AppendTo[newSigns2,newCircles[[1]]->-1];
AppendTo[newSigns2,newCircles[[2]]->1];
constructBasisVector[image,newSigns1]+constructBasisVector[image,newSigns2]
]];

(* Applies the merging differential to a basis vector *)MergingDifferential[k_Integer][b_BasisVector][newCircles:{_List},oldCircles:{_List,_List},image_Resolution]:=Module[
{oldSigns,
newSign,newSigns},
oldSigns=oldCircles/.b[[2]];
newSign=(Times@@oldSigns);
newSigns=DeleteCases[b[[2]],(circle_->value_)/;MemberQ[oldCircles,circle]];
AppendTo[newSigns,newCircles[[1]]->newSign];
constructBasisVector[image,newSigns]
];

LeeDifferential[b_BasisVector]:=LeeDifferential[b]=Sum[LeeDifferentialForCrossing[k][b],{k,1,NumberOfCrossings[b[[1,1]]]}]

LeeDifferential[α_Integer b_BasisVector]:=Collect[α LeeDifferential[b],_BasisVector]
LeeDifferential[X_Plus]:=Collect[LeeDifferential/@X,_BasisVector]

Differential[b_BasisVector]:=Differential[b]=LeeDifferential[b]/.c_BasisVector/;EulerGrading[c]≠EulerGrading[b]:>0

AnnularDifferential[b_BasisVector]:=AnnularDifferential[b]=Differential[b]/.c_BasisVector/;AnnularGrading[c]≠AnnularGrading[b]:>0

dMinus[b_BasisVector]:=Differential[b]-AnnularDifferential[b]

SpectralAnnularDifferential[t_][b_BasisVector]:=SpectralAnnularDifferential[t][b]=Differential[b]/.c_BasisVector:>(t^((-AnnularGrading[c]+AnnularGrading[b])/2))c

MultispectralDifferential[β_,γ_][b_BasisVector]:=(*MultispectralDifferential[β,γ][b]=*)LeeDifferential[b]/.c_BasisVector:>(β^((-AnnularGrading[c]+AnnularGrading[b])/2-(-EulerGrading[c]+EulerGrading[b])/4))(γ^(-(-EulerGrading[c]+EulerGrading[b])/4))c

Clear[AllBasisVectors]
AllBasisVectors[b_BR]:=AllBasisVectors[b]=Flatten[BasisVectors/@CubeOfResolutions[b]]

AllBasisVectorsInHomologicalGrading[b_BR,s_Integer]:=AllBasisVectorsInHomologicalGrading[b,s]=Flatten[BasisVectors/@Cases[CubeOfResolutions[b],r_/;HomologicalGrading[r]==s]]

AllBasisVectorsInGrading[b_BR,s_Integer,r_Integer]:=AllBasisVectorsInGrading[b,s,r]=
Cases[AllBasisVectorsInHomologicalGrading[b,s],v_/;EulerGrading[v]==r]

AllBasisVectorsInGrading[b_BR,s_Integer,r_Integer,k_Integer]:=Cases[AllBasisVectorsInGrading[b,s,r],v_/;AnnularGrading[v]===k]

Clear[DifferentialAsMatrix]

(* Rewrites the differential from grading (s,r) as a matrix *)
DifferentialAsMatrix[b_BR,s_Integer,r_Integer,differential:_:Differential]:=DifferentialAsMatrix[b,s,r,differential]=Module[{vectorsBefore,vectorsAfter},
vectorsBefore=AllBasisVectorsInGrading[b,s,r];
vectorsAfter=AllBasisVectorsInGrading[b,s+1,r];
(*
Print["vectorsAfter: ",vectorsAfter];
(Print[#," ---> ", Differential[#]])&/@vectorsBefore;
*)
Matrix[Length[vectorsBefore],Coefficient[differential/@vectorsBefore,#]&/@vectorsAfter]
]

(* Rewrites the differential from grading s as a matrix *)
DifferentialAsMatrix[b_BR,s_Integer,differential:_:Differential]:=DifferentialAsMatrix[b,s,differential]=Module[{vectorsBefore,vectorsAfter},
vectorsBefore=AllBasisVectorsInHomologicalGrading[b,s];
vectorsAfter=AllBasisVectorsInHomologicalGrading[b,s+1];
(*
Print["vectorsAfter: ",vectorsAfter];
(Print[#," ---> ", Differential[#]])&/@vectorsBefore;
*)
Matrix[Length[vectorsBefore],Coefficient[differential/@vectorsBefore,#]&/@vectorsAfter]
]

Clear[Matrix]
Matrix/:Join[Matrix[numberOfColums_,m1_],Matrix[numberOfColumns_,m2_]]:=Matrix[numberOfColumns,m1~Join~m2]
Matrix/:NullSpace[Matrix[numberOfColumns_,{}]]:=IdentityMatrix[numberOfColumns]
Matrix/:NullSpace[Matrix[0,{}]]:={}
Matrix/:NullSpace[Matrix[numberOfColumns_,entries_]]:=NullSpace[entries]
Matrix/:Transpose[Matrix[numberOfColumns_,entries_]]:=Matrix[Length[entries],Transpose[entries]]
Matrix/:Transpose[Matrix[numberOfColumns_,{}]]:=Matrix[0,Table[{},{numberOfColumns}]]
Matrix/:LinearSolve[m_,Matrix[numberOfColumns_,{}]]:=(Print["LinearSolve[",m,", Matrix[",numberOfColumns,", {}]]"];Abort[])
Matrix/:LinearSolve[m_,Matrix[numberOfColumns_,entries_]]:=LinearSolve[m,entries]
Matrix/:RowReduce[Matrix[n_,{}]]:=Matrix[n,{}]
Matrix/:RowReduce[Matrix[n_,m_]]:=Matrix[n,RowReduce[m]]

KhBoundaryRepresentativesInGrading[b_BR,s_Integer,r_Integer,differential:_:Differential]:=Module[{},
DeleteCases[RowReduce[Transpose[DifferentialAsMatrix[b,s-1,r,differential]]][[2]],{0...}]
]

Clear[KhRepresentativesInGrading]
KhRepresentativesInGrading[b_BR,s_Integer,r_Integer,differential:_:Differential]:=KhRepresentativesInGrading[b,s,r,differential]=Module[{d2,d1,kernel, image,complementInKernelBasis},
(*Print["Computing KhRepresentativesInGrading[",b,", ",s,", ",r,"]"];*)
d2=DifferentialAsMatrix[b,s,r,differential];
d1=DifferentialAsMatrix[b,s-1,r,differential];
(*Print["d1 = ",d1];
Print["d2 = ",d2];*)
NullSpace[d2~Join~Transpose[d1]]
]

KhInGrading[b_BR,s_Integer,r_Integer,differential:_:Differential]:=Length[KhRepresentativesInGrading[b,s,r,differential]]

Kh[b_BR,differential:_:Differential]:=Sum[(t^s)(q^r)KhInGrading[b,s,r,differential],{s,AllHomologicalGradings[b]},{r,AllEulerGradings[b]}]

Clear[e]
e[b:BasisVector[resolution_,signs_]]:=Sum[e[b,k],{k,1,Length[signs]}]
e[b:BasisVector[resolution_,signs_],k_]/;!CircleEssentialQ[basePointArc[resolution],signs[[k,1]]]:=0
e[b:BasisVector[resolution_,signs_],k_]/;signs[[k,2]]==1:=0
e[b:BasisVector[resolution_,signs_],k_]/;signs[[k,2]]==-1:=(((-1))^(Position[basePointArc[resolution],Min[Intersection[basePointArc[resolution],signs[[k,1]]]]][[1,1]]+1))ReplacePart[b,{2,k,2}->1]
e[X_Plus]:=e/@X
e[α_Integer X_]:=α e[X]

Clear[f]
f[b:BasisVector[resolution_,signs_]]:=Sum[f[b,k],{k,1,Length[signs]}]
f[b:BasisVector[resolution_,signs_],k_]/;!CircleEssentialQ[basePointArc[resolution],signs[[k,1]]]:=0
f[b:BasisVector[resolution_,signs_],k_]/;signs[[k,2]]==-1:=0
f[b:BasisVector[resolution_,signs_],k_]/;signs[[k,2]]==1:=(((-1))^(Position[basePointArc[resolution],Min[Intersection[basePointArc[resolution],signs[[k,1]]]]][[1,1]]+1))ReplacePart[b,{2,k,2}->-1]
f[X_Plus]:=f/@X
f[α_Integer X_]:=α f[X]

Clear[eAsMatrix]
eAsMatrix[b_BR,s_Integer,r_Integer]:=(*eAsMatrix[b,s,r]=*)Module[{representatives,vectorsBefore,vectorsAfter},
representatives=KhRepresentativesInGrading[b,s,r,AnnularDifferential];
If[Length[representatives]==0,Matrix[0,Table[{},{v,AllBasisVectorsInGrading[b,s,r+2]}]],
vectorsBefore=representatives.AllBasisVectorsInGrading[b,s,r];
vectorsAfter=AllBasisVectorsInGrading[b,s,r+2];
Matrix[Length[vectorsBefore],Coefficient[e/@vectorsBefore,#]&/@vectorsAfter]
]
]

(*
We compute highest weight vectors, by finding highest weight vectors amongst representatives for the homology.

This works, because the quotient map from the cube complex to the annular homology is a map of sl_2 representations.
*)
Clear[AnnularHeighestWeightVectors]
AnnularHeighestWeightVectors[b_BR,s_Integer,r_Integer]:=(*AnnularHeighestWeightVectors[b,s,r]=*)Module[{kernel},
kernel=NullSpace[eAsMatrix[b,s,r]];
If[Length[kernel]==0,{},kernel.KhRepresentativesInGrading[b,s,r,AnnularDifferential].AllBasisVectorsInGrading[b,s,r]]
]

AnnularHeighestWeightVectorsAsLinearCombosOfRepresentatives[b_BR,s_Integer,r_Integer]:=(*AnnularHeighestWeightVectors[b,s,r]=*)Module[{kernel},
kernel=NullSpace[eAsMatrix[b,s,r]];
If[Length[kernel]==0,{},kernel.KhRepresentativesInGrading[b,s,r,AnnularDifferential]]
]

AnnularKh[b_BR]:=AnnularKh[b]=Sum[With[{λ=AnnularGrading[v]},(t^s)(q^(r-λ))V[λ]],{s,AllHomologicalGradings[b]},{r,AllEulerGradings[b]},{v,AnnularHeighestWeightVectors[b,s,r]}]

$annularKhPath=NotebookDirectory[];
SaveAnnularKh[]:=(LoadAnnularKh[];Put[DownValues[AnnularKh],FileNameJoin[{$annularKhPath,"annularKh.m"}]])
LoadAnnularKh[]:=(DownValues[AnnularKh]=Union[DownValues[AnnularKh]~Join~Get[FileNameJoin[{$annularKhPath,"annularKh.m"}]]];)

PositiveStabilization[BR[b_,X_]]:=BR[b+1,X~Join~{b}]

PositiveStabilization[BR[b_,X_],0]:=BR[b,X]
PositiveStabilization[BR[b_,X_],1]:=PositiveStabilization[BR[b,X]]
PositiveStabilization[BR[b_,X_],k_/;k>1]:=PositiveStabilization[PositiveStabilization[BR[b,X]],k-1]

NegativeStabilization[BR[b_,X_]]:=BR[b+1,X~Join~{-b}]

NegativeStabilization[BR[b_,X_],0]:=BR[b,X]
NegativeStabilization[BR[b_,X_],1]:=NegativeStabilization[BR[b,X]]
NegativeStabilization[BR[b_,X_],k_/;k>1]:=NegativeStabilization[NegativeStabilization[BR[b,X]],k-1]

Stabilization[b_,{1,X___}]:=Stabilization[PositiveStabilization[b],{X}]
Stabilization[b_,{-1,X___}]:=Stabilization[NegativeStabilization[b],{X}]
Stabilization[b_,{}]:=b

Testing

CubeOfResolutions[BR[Knot["4 1"]]]//TableForm

BraidPlot[BR[Knot[4,1]]]

Kh[BR[Knot["3_1"]]]//AbsoluteTiming

KhRepresentativesInGrading[BR[Knot["3_1"]],0,-5,AnnularDifferential].AllBasisVectorsInGrading[BR[Knot["3_1"]],0,-5]

e/@%

Kh[BR[Knot["3_1"]],AnnularDifferential]

AnnularKh[BR[3,{1,2,1}]]

AnnularKh[BR[3,{1,2,1,1,2,1}]]

AnnularKh[BR[4,{1,2,3,1,2,1}]]

AnnularKh[BR[5,{1,2,3,4,1,2,3,1,2,1}]]

PositiveStabilization[BR[2,{-1,-1,-1}],3]

AnnularKh[PositiveStabilization[BR[1,{}],2]]

Table[AnnularKh[PositiveStabilization[BR[1,{}],k]],{k,0,4}]//TableForm

AnnularKhDifference[b_BR,k_Integer]:=Collect[AnnularKh[PositiveStabilization[b,k+1]]-q(AnnularKh[PositiveStabilization[b,k]]/.V[λ_]:>V[λ+1]),_V]

Table[AnnularKhDifference[BR[1,{}],k],{k,0,4}]

Table[AnnularKhDifference[BR[Knot["3_1"]],k],{k,0,4}]

Table[AnnularKhDifference[BR[Knot["4_1"]],k],{k,0,2}]

Table[AnnularKh[PositiveStabilization[BR[Knot["3_1"]],k]],{k,0,4}]//TableForm

Table[AnnularKh[PositiveStabilization[BR[Knot["4_1"]],k]],{k,0,4}]//TableForm

Expand[AnnularKh[BR[Knot["3_1"]]]/.V[λ_]:>Sum[(q^k),{k,-λ,λ,2}]]===Kh[BR[Knot["3_1"]],AnnularDifferential]

Kh[BR[Knot["8_19"]],AnnularDifferential]

Kh[BR[Knot["8_19"]],AnnularDifferential]/.t->-1

Kh[BR[Knot["4_1"]]]//AbsoluteTiming

BR[Knot["4_1"]]

Kh[BR[Knot["8_19"]]]//AbsoluteTiming

Kh[BR[Knot["8_20"]]]//AbsoluteTiming