Dror Bar-Natan: Odds, Ends, Unfinished:

Some One Parameter Knot Theory Computations

By Dror Bar - Natan and Thomas Fiedler

This Mathematica notebook contains some programs that we wrote in June 2007 to compute some knot invariants coming out of Fiedler's "one-parameter" approach to knot theory as described in arXiv:math/0612115.

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 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 Jones polynomial, and while we could not compute enough of the second to fully identify it, we computed enough to tell that contrary it does not separate (Subscript[8, 17]) from its inverse. So no jackpot here, but a new and unexplained construction of the Jones 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, 2007. It is not easily readable and not meant for readership much beyond its own authors. Don't bother complaining.

The .nb (original) version of this notebook is at http://www.math.toronto.edu/~drorbn/Misc/OneParameter/OneParameter.nb.

T1=Date[]

T0, the time stamp on the first version of this document, was {2007, 6, 17, 14, 26, 8.1093750}.

Pictures

The Scanning Process

The C1 Smoothing and the C1Bar Smoothing

The Distinguished Crossing and the distinguished Loop

The Scanning Process for the Double

KnotTheory` and some modifications

<< KnotTheory`

BeginPackage["KnotTheory`"];

PD[BR[k_Integer,l_List]]:=Module[
{a,b,c,d,e,f,g,m=k,j,j1,pd,ul, closurerule,loops},
loops=g=Range[k];
pd=PD@@Flatten[l/.{
j_Integer:>(
j1=Abs[j];
loops=DeleteCases[loops, j1|j1+1];
a=g[[j1]];b=g[[j1+1]];
c=g[[j1]]=++m;d=g[[j1+1]]=++m;
If[j>0,X[b,d,c,a],X[a,b,d,c]]
),
C1[j_] :> (
j1=Abs[j];
loops=DeleteCases[loops, j1+1|j1+2];
b=g[[j1+1]]; c=g[[j1+2]];
e=g[[j1+1]]=++m;f=g[[j1+2]]=++m;
{P[b,c], P[e,f]}
),
C1bar[j_] :> (
j1=Abs[j];
loops=DeleteCases[loops, j1|j1+1];
a=g[[j1]]; b=g[[j1+1]];
d=g[[j1]]=++m; e=g[[j1+1]]=++m;
{P[a,b], P[d,e]}
)
}];
closurerule=MapThread[Rule,{g,Range[k]}];
pd=pd/.closurerule;
Join[pd,Loop/@PD@@Range[m+1,m+Length[loops]]]
];

KB[PD[],_,web_]:=Expand[web];
KB[PD[y___, _Loop,x___],inside_,web_]:=Expand[(-A^2-1/A^2)KB[PD[y,x],inside,web]]
KB[pd_PD,inside_,web_]:=Module[{pos=First[Ordering[Length[Complement[List@@#,inside]]&/@List@@pd]]},pd[[pos]]/.{X[a_,b_,c_,d_]:>KB[Delete[pd,pos],Union[inside,{a,b,c,d}],Expand[web*(1/A P[a,d] P[b,c]+A P[a,b] P[c,d])]//.{P[e_,f_]P[f_,g_]:>P[e,g],P[e_,e_]->-A^2-1/A^2,P[__]^2->-A^2-1/A^2}],P[a_,b_]:>KB[Delete[pd,pos],Union[inside,{a,b}],Expand[web*P[a,b]]//.{P[e_,f_]P[f_,g_]:>P[e,g],P[e_,e_]->-A^2-1/A^2,P[__]^2->-A^2-1/A^2}]}];
KB[pd_PD] := KB[pd, {}, 1];
KB[b_] := KB[b] = Cancel[KB[PD[b]]/(-A^2-1/A^2)];

BR /: Permutation[BR[w_, br0_List]] := Module[
{p=Range[w], i, j},
Do[
j=Abs[br0[[i]]];
p[[{j, j+1}]] = p[[{j+1, j}]],
{i, Length[br0], 1, -1}
];
p
];

EndPackage[]

Specific Programs

MovieFrame[BR[w_, br0_List], k_] := Module[
{xk, j},
xk=br0[[k]];
BR[w+1,
Join[
Take[br0, k-1],
Table[j, {j, w, Abs[xk]+2, -1}],
{T[xk]},
Table[j, {j,Abs[xk]-1, 1, -1}],
Drop[br0, k] /. {j_Integer :> If[j>0, j+1, j-1]},
Table[-j, {j, 2, w}]
]
]
];

Orbit[BR[w_, br0_List]] := Module[
{i,i1, j, j1,br1,  t, p, p1, c, orb},
{{i}} = Position[br0, _T];
j1=Abs[j=br0[[i,1]]];
br1= Flatten[ReplacePart[br0, i -> {j1+1, j1, Sign[j]*(j1+1)}]];
If[j<0,
i1=i; t=j1+2,
i1=i+1; t=j1+1
];
p1 =Permutation[BR[w, Reverse[Take[br1, i1-1]]]];
p=Permutation[BR[w, Delete[br1, i1]]];
orb={t=p1[[t]]}; c=p[[t]];
While[c≠t, AppendTo[orb,c]; c=p[[c]]];
orb
]

FS[K_] := FS[K] = Module[
{br,w,br0,xk,sb},
br=BR[K];
Table[
xk=br[[2, k]];
sb=MovieFrame[br, k];
Expand[List[
-Sign[xk],
{KB[sb /. T -> C1] ,  KB[sb /. T -> C1bar]},
If[xk >0, 1, -A^2],
A^(8Length[Orbit[sb]])
]],
{k, Crossings[br]}
]
];
FiedlerS[K_] := (Plus @@ Times @@@ FS[K]).{1,-1} // Expand

TwistedDouble[BR[w_, br_List]] := BR[2w, Append[
Flatten[br /. {
j_Integer :> (2Abs[j]+{2,1,3,2}-2)Sign[j]
}],
1
]];

DS0[K_] := Module[
{br,w,br0,xk,sb,orb},
br=TwistedDouble[BR[K]];
Table[
xk=br[[2, k]];
sb=MovieFrame[br, k];
Expand[List[
-Sign[xk],
{KB[sb /. T -> C1] ,  KB[sb /. T -> C1bar]},
If[xk >0, 1, -A^2],
A^(8Length[orb=Orbit[sb]]),
t^Count[orb,2]
]],
{k, Crossings[br]}
]
];
DS[K_] := (Plus @@ Times @@@ DS0[K]).{1,-1} // Expand

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

K=Knot[4,1]

BraidPlot[br=BR[K]]

FS[K]

The first invariant

FiedlerS[K]

Factor[FiedlerS[K] / KB[K]]

The second invariant

DS[K]

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

DataSet[K_] := (
br=BR[K];
Print[ds={
Knot -> K,
BraidIndex -> First[br],
FiedlerS -> (fs=FiedlerS[br]),
FKQuotient ->
Expand[
Factor[fs/(A^10*(1-A+(A^2))*(1+A+(A^2))*(1-(A^2)+(A^4))*KB[br])]
]
}];
ds
)

DataSet /@ AllKnots[3];

DataSet /@ AllKnots[4];

DataSet /@ AllKnots[5];

DataSet /@ AllKnots[6];

DataSet /@ AllKnots[7];

Note that FKQuotient, a slightly renormalized quotient of FiedlerS and the Kauffman bracket, is always of the form 1+(A^8)+...+(A^(b-2)), 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: "Fiedler S for Double" (DS) for (Subscript[8, 17]) and its inverse

The results below were computed on {2007, 6, 17} and the "frozen" to save on unnecessary re-computations.

Timing[DS[Knot[8,17]]]

Timing[DS[BR[Knot[8,17]] /. xs_List :> Reverse[xs]]]