Dror Bar-Natan: Odds, Ends, Unfinished:

Some HOMFLY-PT One Parameter Knot Theory Computations

By Jana Archibald, Dror Bar - Natan, Karene Chu and Thomas Fiedler

This Mathematica notebook contains some programs that we wrote in June 2008 to compute some knot invariants coming out of Fiedler's "one-parameter" approach to knot theory as described in arXiv:math/0612115. This is much like the computations by Bar-Natan and Fiedler from June 2007, except this time the underlying knot invariant is the HOMFLY-PT polynomial instead of the Jones polynomial.

In short, the idea is to associate in some canonical way a "knot movie", or more precisely, a "one-parameter family of knot diagrams" to a given knot diagram. Within a generic knot movie some "frames" will be singular. In the said article Fiedler constructs a state sum invariant of "knot diagrams with a triple crossing" in much of the same way as knot invariants are constructed using state sums involving just standard knot diagrams. When those "triple-crossing state sums" satisfy certain complicated conditions, they yield invariants of knot movies, and when evaluated on the movies canonicaly associated with knot diagrams, they yield knot invariants.

This time around we rely on unpublished work by Fiedler, in which the relevant "state sum" is replaced by a HOMFLY-PT-inspired invariant.

This construction seems new and little is known about it. While the invariants it produces are always finite type, they are otherwise potentially new.

In this notebook we compute two of the simplest knot invariants introduced by Fiedler. The results are in some sense disappointing - the first of the two invariants quite clearly comes out to by a multiple of the HOMFLY-PT polynomial, and while we could not compute enough of the second to fully identify it, we computed enough to tell that it does not separate (Subscript[8, 17]) from its inverse. So no jackpot here, but a new and unexplained construction of the HOMFLY-PT polynomial is surely an interesting thing. Where does it come from? What exactly is the universe of all such constructions? Are there news in any of the others?

The main purpose of this notebook is to preserve our efforts of June 16-22, 2008. It is not easily readable and not meant for readership much beyond its own authors. Don't bother complaining.

Along the way we had to compute the HOMFLY-PT polynomial for rather large knots, ones fro which the existing code in the package KnotTheory` was hugely insufficient. Therefore we wrote some new Hecke-algebra sparse-matrix code to compute the HOMFLY-PT polynomial (the program "Homf", below). This code is not yet well tested and is not yet a part of  KnotTheory`, but we hope to incorporate it into KnotTheory` soon.

The .nb (original) version of this notebook is at http://www.math.toronto.edu/~drorbn/Misc/OneParameter/OneParameterY.nb. Some blackboard shots taken when we were working ar at http://katlas.math.toronto.edu/drorbn/bbs/show?shot=Fiedler-080616-084319.jpg.

T1=Date[]

T0, the time stamp on the first version of this document, was {2008, 6, 21, 15, 26, 37.1262000}.

Handwritten Definitions

(We conjecture that the uncabled invariant coincides with the HOMFLY - PT polynomial up to normalization. See "The First Invariant" below.)

KnotTheory` and data files

<< KnotTheory`

Some pre - computed Hecke matrices are available at http://www.math.toronto.edu/~drorbn/Misc/OneParameter/HeckeData.zip Stricktly speaking, they are not necessary for the computations below, but they make them a lot faster. The file HeckeData.zip is in itself quite big (39MB) and takes about a minute to load into mathematica. If you are about to do large scale computations, fix the path below to suit your system and execute the following line:

Import["C:/drorbn/People/Fiedler/2008-06/HeckeData.zip", "HeckeData.m"];

Our Programs

Perm /: Perm[p1___]**Perm[p2___] := Perm[p2][[{p1}]];
Perm[BR[n_, {}]] := Perm @@ Range[n];
Perm[BR[n_, {xs___, x_}]] := Module[{a=Abs[x]},
Perm[BR[n, {xs}]] /. {a-> a+1, a+1->a}
];

Phi2[b_BR, k_] := Module[
{n=First@b,perm,tt},
perm=Perm[b];
Sum[
tt=i;
While[tt>n-k, tt=perm[[tt]]];
-d*t[tt]*BR[n,Join[
-Range[n-k+1,i-1],
Last@b,
-Range[1,n-k-1],
Range[i-1,1,-1]
]],
{i,n-k+1,n}
]
];
Phi3[BR[n_, xings_List], k_] := Module[
{l=Length[xings],j, lft, rgt,jj,perm,tt},
Sum[
j=Abs[xings[[i]]];
lft=Join[
-Range[n-k+1,n],
Take[xings,i-1],
Range[n,2+j,-1]
];
rgt=Join[
Range[j-1,1,-1],
Drop[xings,i] /. {jj_Integer :> jj+Sign[jj]},
-Range[2,n-k]
];
perm=Perm[BR[n+1,Join[lft,{j,j+1,j}, rgt]]];
tt=Perm[BR[n+1,rgt]][[If[xings[[i]]>0,j+2, j+1]]];
While[tt>n-k, tt=perm[[tt]]];
Expand[t[tt]*(
BR[n+1,Join[lft,{j+1}, rgt]]-BR[n+1,Join[lft,{j}, rgt]]
)],
{i,l}
]
];

Flip[x_,j_] := ReplacePart[x, {j->x[[j+1]], j+1->x[[j]]}];
HB /: hb_HB * BR[_,{}] := hb;
HB /: hb_HB * BR[_,{j_}] /; j>0 := If[hb[[j]]<hb[[j+1]],
Flip[hb, j],
z*hb+Flip[hb,j]
];
HB /: hb_HB*BR[_, {j_}] /; j<0 := If[hb[[-j]] < hb[[1-j]],
Flip[hb, -j]- z*hb,
Flip[hb, -j]
];
HB /: hb_HB*BR[_, {j_, js__}] := Expand[Expand[hb*BR[0, {j}]]*BR[0, {js}]];
Proj[n_, x_] := Expand[HB@@Range[n]*x];
Proj[BR[n_, l_]] := Proj[n, BR[n,l]];

cl[0, x_] := x;
cl[k_, x_Plus] := cl[k,#]& /@ x;
cl[k_, hb_HB*x_.] := Module[
{n=Length[hb],p},
Expand[
cl[k-1, Expand[x*If[Last[hb]==n,
d*Drop[hb, -1],
1/v * DeleteCases[hb, n]*BR[0,Range[n-2,Position[hb, n][[1,1]],-1]]
]]]
]
];

Y1[BR[n_, xings_]] := Expand[(
cl[n, Proj[n+1, Phi3[BR[n,xings], n-1]]] + cl[n-1, Proj[n, Phi2[BR[n,xings], n-1]]]
) /. d -> (1/v-v)/z];

Double[BR[w_,br_List]] :=BR[2 w,Flatten[{
br/.{j_Integer:>{2 j+{0,-1,1,0}}},
Table[-Sign[Total[Sign@br]],{2*Abs[Total[Sign@br]]}]
}]];

Y2[B_BR] := Module[
{DB=Double[B], n=First@B},
Expand[(
cl[2n-1, Proj[2n+1, Phi3[DB, 2n-2]]] + cl[2n-2, Proj[2n, Phi2[DB, 2n-2]]]
) /. d -> (1/v-v)/z]
];

IndexOfPermutation[0,{}]=0;
IndexOfPermutation[1, {1}]=0;
IndexOfPermutation[n_, l_] := (
(n-1)!(n-Position[l, n][[1,1]])
+IndexOfPermutation[n-1, Drop[l, -1] /. n -> Last[l]]
);
PermutationByIndex[0, 0] = {};
PermutationByIndex[1, 0] = {1};
PermutationByIndex[n_, k_] := Block[
{
tau=PermutationByIndex[n-1, k~Mod~((n-1)!)], p=n-k~Quotient~((n-1)!)
},
If[p==n,
Append[tau,n],
Append[tau /. tau[[p]] -> n, tau[[p]]]
]
];

HeckeMatrix[n_, j_] := HeckeMatrix[n, j] = Module[
{out,i},
SparseArray[Flatten[Table[
out=HB@@PermutationByIndex[n, i]*BR[0,{j}];
({i, IndexOfPermutation[n, List@@#]}+1 -> Coefficient[out, #])& /@ Cases[{out}, _HB, Infinity],
{i,0, n!-1}
]]]
];

HM[n_, j_] := HM[n,j] = SMP[
Map[Coefficient[#, z,0]&, HeckeMatrix[n,j], {2}],
Map[Coefficient[#, z,1]&, HeckeMatrix[n,j], {2}]
];

SMP /: x_SMP ** y_SMP := Module[
{degx=Length[x]-1, degy=Length[y]-1, i,k},
SMP@@Table[
Sum[
x[[i+1]].y[[k-i+1]],
{i,Max[0,k-degy],Min[degx, k]}
],
{k, 0, degx+degy}
]
];

ClosureMatrix[n_] := ClosureMatrix[n] = Module[
{out,i},
SparseArray[Flatten[Table[
out=Expand[cl[1, HB@@PermutationByIndex[n, i]] /. d-> (1/v-v)/z];
({i, IndexOfPermutation[n-1, List@@#]}+1 -> Coefficient[out, #])& /@ Cases[{out}, _HB, Infinity],
{i,0, n!-1}
]]]
];
ClosureMatrix[n_,1] := ClosureMatrix[n];
ClosureMatrix[n_, k_] /; k>1 := ClosureMatrix[n, k] = Map[
Expand, ClosureMatrix[n].ClosureMatrix[n-1, k-1], {2}
];

Homf[BR[n_, l_], k_] := Module[
{debug=False, tu, HStep, CStep, hm, out},
If[debug, tu=TimeUsed[]; Print["Homf at ", BR[n,l], ", ",k]];
HStep[h_, j_] := h**HM[n,j];
CStep[h_, j_] := Map[Expand, Dot[h, ClosureMatrix[j]], {1}];
hm = Fold[HStep, SMP[SparseArray[{{1} -> 1}, {n!}]], l];
If[debug, Print["Computed hm, time is ", TimeUsed[]-tu]];
out=Normal[Fold[CStep, z^Range[0, Length[hm]-1].(List@@hm), Range[n, n-k+1, -1]]];
If[debug, Print["Computed out, time is ", TimeUsed[]-tu]];
out
];
Homf[b_BR] := Homf[b, First@b-1];
Homf[K_] := Homf[BR[K]];

FastY1[BR[n_, xings_]] := Expand[Plus[
Phi3[BR[n,xings], n-1] /. b_BR :> Homf[b, n],
Phi2[BR[n,xings], n-1] /. b_BR :> Homf[b, n-1]
] /. d -> (1/v-v)/z];
FastY1[K_] := FastY1[BR[K]];

FastY2[B_BR] := Module[
{DB=Double[B], n=First@B},
Expand[Plus[
Phi3[DB, 2n-2] /. b_BR :> Homf[b, 2n-1],
Phi2[DB, 2n-2] /. b_BR :> Homf[b, 2n-2]
] /. d -> (1/v-v)/z]
];
FastY2[K_] := FastY2[BR[K]];

The knot (Subscript[4, 1]), just for fun

K=Knot[4,1]

BraidPlot[br=BR[K]]

Homf[K]

The first invariant

FastY1[K]

Factor[FastY1[K] /Homf[K]]

The second invariant

FastY2[K]

The first invariant, for all knots with at most 7 crossings

DataSet[K_] := (
br=BR[K];
Print[ds={
Knot -> K,
BraidIndex -> First[br],
Y1 -> (y1=FastY1[br]),
YHQuotient ->Factor[y1/Homf[br]]
}];
ds
)

DataSet /@ AllKnots[3];

DataSet /@ AllKnots[4];

DataSet /@ AllKnots[5];

DataSet /@ AllKnots[6];

DataSet /@ AllKnots[7];

Note that YHQuotient, the quotient of Y1 and the (framed) HOMFLY-PT polynomial, is always of the form -(b-1)t[1]/v, where b is the braid index. This pattern persists for all knots we tested, including all knots with up to 10 crossings.

The second invariant: "Y for Double" (Y2) for (Subscript[8, 17]) and its inverse

The results below were computed on June 21, 2008 and then "frozen" to save on unnecessary re-computations.

Timing[t1=FastY2[Knot[8,17]]]

Timing[t2=FastY2[BR[Knot[8,17]] /. xs_List :> Reverse[xs]]];

t1==t2

The second invariant: Y2 for the Conway and Kinoshita-Terasaka Knots

The results below were computed from June 19, 2008 until June 22, 2008 and then "frozen" to save on unnecessary re-computations.

Timing[t3=FastY2[BR[Knot["K11n34"]]]]

Timing[FastY2[BR[Knot["K11n42"]]] == t3]

The Second Invariant for Knots with Braid Index 2 and 3 and up to 7 crossings

DataSet2[K_] := (
b=BR[K];
Print[(ds={
Knot -> K,
BraidIndex -> First[b],
H1 -> Homf[b],
H2 -> Homf[db=Double[b]],
H2t -> Homf[db /. {xs__} :> {xs, 1}],
Y2 -> FastY2[b]
}) /. t[i_] :> (Subscript[t, i])];
ds
)

Ks=Select[AllKnots[{3,7}], (2 ≤ BraidIndex[#] ≤ 3)&]

The results below were computed on June 22, 2008 and then "frozen" to save on unnecessary re-computations.

DataSet2 /@ Ks;

Recycling

The code below was ultimately not used, but it is preserved for the purpose of possible future use.

TwistedDouble[BR[w_,br_List]] :=BR[2 w,Flatten[{
br/.{j_Integer:>{2 j+{0,-1,1,0}}},
Table[-Sign[Total[Sign@br]],{2*Abs[Total[Sign@br]]}], {1}
}]];
Phi3Table[BR[n_, xings_List], k_] := Module[
{l=Length[xings],j, lft, rgt,jj,perm,tt},
Table[
j=Abs[xings[[i]]];
lft=Join[
-Range[n-k+1,n],
Take[xings,i-1],
Range[n,2+j,-1]
];
rgt=Join[
Range[j-1,1,-1],
Drop[xings,i] /. {jj_Integer :> jj+Sign[jj]},
-Range[2,n-k]
];
perm=Perm[BR[n+1,Join[lft,{j,j+1,j}, rgt]]];
tt=Perm[BR[n+1,rgt]][[If[xings[[i]]>0,j+2, j+1]]];
While[tt>n-k, tt=perm[[tt]]];
Expand[t[tt]*(
BR[n+1,Join[lft,{TP[j]}, rgt]]
)],
{i,l}
]
];

b=Phi3Table[TwistedDouble[BR[Knot[4,1]]],5][[10]] /t[1]

{n,l}=List@@b; len=Length[l];
Module[
{t},
Clear[kt];
kt[s=1, i=0] = t= 0;
While[{s,i} ≠ {1, len},
If[(++i) > len, kt[s,i]=t; i=0];
l[[i]] /. {
j_Integer /; s==Abs[j] :> (kt[++s, i]=++t),
j_Integer /; s==(1+Abs[j]) :> (kt[--s, i]=++t),
TP[j_] /; s==Abs[j] :> (kt[s+=2, i]=++t),
TP[j_] /; s==Abs[j]+1 :> (kt[s, i]=++t),
TP[j_] /; s==Abs[j]+2 :> (kt[s-=2, i]=++t),
_ :> (kt[s,i]=t)
}
]];
tpi=Position[l, _TP][[1,1]];
tpj= Abs[l[[tpi,1]]];  tps=Sign[l[[tpi,1]]];
kt[j_] := kt[j, tpi-1];
Table[kt[s,i], {s,n}, {i,0,Length[l]}] // MatrixForm

tp=If[s>0,
TP[kt[tpj+2], kt[tpj+1], kt[tpj]],
TP[kt[tpj+2], kt[tpj], kt[ tpj+1]]
];
gds=Delete[Table[
j=Abs[l[[i]]];
If[l[[i]]<0,
X[kt[j+1, i-1], kt[j, i-1]],
X[kt[j, i-1], kt[j+1, i-1]]
],
{i,len}
], tpi]*tp;
gds = (# /. Thread[Sort[Cases[#, _Integer, Infinity]] -> {1,2,3,4,5}])& /@gds

CyclicQ[a_,b_,c_,d_] := If[MemberQ[
{{1,2,3,4},{2,3,4,1},{3,4,1,2},{4,1,2,3}},
Ordering[{a,b,c,d}]
],1,0];
gds /. TP[t1_, t2_, t3_] X[t4_, t5_] :> {
{t1,t2,t3,t4,t5},
eta=If[Signature[{t1,t2,t3}]== 1, 0, 1],
alpha1=CyclicQ[t1,t3,t5,t4],
alpha2=CyclicQ[t1,t4,t5,t3],
alpha3=If[eta==0, CyclicQ[t1,t5,t3,t4], CyclicQ[t1,t4,t3, t5]],
alpha1+alpha2+alpha3
}