Once[
SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\ICERM-2305"];
<< KnotTheory`;
]

ω2[v_][p_]:=Module[{q=Expand[p],n,c},
If[q===0,0,c=Coefficient[q,ω,n=Exponent[q,ω]];c (v^n)+ω2[v][q-c(((ω+(ω^(-1))))^n)]]];

θ[x_]/;NumericQ[x]:=HeavisideTheta[x]

sign[ℰ_]:=Module[{num,den,v,p,rs,d,k},
{num,den}=NumeratorDenominator[ℰ];{num,den}/=(ω^(Exponent[num,ω]/2));
p=Factor[Times@@(ω2[v]/@{num,den})/.v->4(u^2)-2];
rs=Solve[p==0,u,Reals];
If[rs==={}, Return[Sign[p/.u->0]]];
rs=Union@(u/.rs);
Sign[Coefficient[p,u,Exponent[p,u]]](((-1))^(Exponent[p,u]))+Sum[
k=1; While[(d=RootReduce[D[p,{u,k}]/.u->r])==0, ++k];
If[EvenQ[k],0,2Sign[d]]θ[u-r],
{r,rs}] ]

SetAttributes[B, Orderless];
CF[b_B]:=RotateLeft[#,First@Ordering[#]-1]&/@DeleteCases[b,{}]

CF[ℰ_]:=Module[{ηs=Union@Cases[ℰ,(Subscript[η, _])|(Subscript[(OverBar[η]), _]),∞]},
Total[CoefficientRules[ℰ,ηs]/.(ps_->c_):>Factor[c]Times@@((ηs)^ps)] ]

CF[{}]={};
CF[rs_List]:=Module[{ηs=Union@Cases[rs,(Subscript[η, _]),∞],η},
CF/@DeleteCases[0][
RowReduce[Table[(∂_η)r,{r,rs},{η,ηs}]].ηs]  ]

(SuperStar[(ℰ_)]):=ℰ/.{(OverBar[η])->η,η->(OverBar[η]),ω->(ω^(-1)),c_Complex:>c\[Conjugate]};
(SuperPlus[r_Rule]):={r,(SuperStar[r])}

{(SuperStar[((2u-ω+3(ω^(-1)))(Subscript[(OverBar[η]), 1])(Subscript[η, 2]))]), (SuperPlus[((Subscript[η, 1])->ω (Subscript[η, 2]))])}

RulesOf[(Subscript[η, i_])+rest_.]:=(SuperPlus[((Subscript[η, i])->-rest)]);
CF[PQ[rs_,q_]]:=Module[{nrs=CF[rs]},
PQ[nrs,CF[q/.Union@@RulesOf/@nrs]]  ]

CF[{(Subscript[η, 1])-(Subscript[η, 2]),(Subscript[η, 1])-(Subscript[η, 3])}]

RulesOf[(Subscript[η, 1])+(Subscript[η, 2])+(Subscript[η, 3])]

CF[(Subscript[Σ, b_])[σ_,pq_]]:=(Subscript[Σ, CF[b]])[σ,CF[pq]]

Format[(Subscript[Σ, b_B])[σ_,PQ[rs_,q_]]]:=Module[{ηs},
ηs=(Subscript[η, #])&/@Join@@b;
Join[
Prepend[""]/@Table[TraditionalForm[(∂_c)r],{r,rs},{c,ηs}],
{Prepend[TraditionalForm@σ][
Join@@(b/.{l_,m___,r_}:>{DisplayForm@RowBox[{"(",l}],m,DisplayForm@RowBox[{r,")"}]})/.i_Integer:>(Subscript[η, i])
]},
MapThread[Prepend,{Table[TraditionalForm[(∂_(r,c))q],{r,(SuperStar[ηs])},{c,ηs}],(SuperStar[ηs])}]
]
]//MatrixForm;

The disjoint union in the world of multi-tangles.

(Subscript[Σ, b1_])[σ1_,PQ[rs1_,q1_]]⋃(Subscript[Σ, b2_])[σ2_,PQ[rs2_,q2_]]^:=CF@(Subscript[Σ, Join[b1,b2]])[σ1+σ2,PQ[rs1⋃rs2,q1+q2]];

Gaps are named after the strand that follows them!

FM for Face Merge:

(Subscript[FM, i_,j_])@(Subscript[Σ, B[{li___,i_,ri___},{lj___,j_,rj___},bs___]])[σ_,PQ[rs_,q_]]:=CF@(Subscript[Σ, B[{ri,li,j,rj,lj,i},bs]])[σ,PQ[rs⋃{(Subscript[η, i])-(Subscript[η, j])},q]]

(Subscript[Σ, B[{-1,2}]])[0,PQ[{},0]]⋃(Subscript[Σ, B[{-3,4}]])[0,PQ[{},0]]//(Subscript[FM, -1,4])

(Subscript[Cordon, i_])@(Subscript[Σ, B[{li___,i_,ri___},bs___]])[σ_,PQ[rs_,q_]]:=Module[{ ϕ=(∂_(Subscript[η, i]))rs,nσ=σ,nrs=rs,nq=q,qii,p},
Which[
Or@@((#=!=0)&/@ϕ), ({p}=FirstPosition[(#===0)&/@ϕ,False];
{nrs,nq}={rs,q}/.(SuperPlus[((Subscript[η, i])->-rs[[p]]/ϕ[[p]])])/.(SuperPlus[((Subscript[η, i])->0)])),
(qii=(∂_((Subscript[(OverBar[η]), i]),(Subscript[η, i])))q)=!=0,(nσ+=sign[qii];nq=q/.(SuperPlus[((Subscript[η, i])->-((∂_(Subscript[(OverBar[η]), i]))q)/qii)])/.(SuperPlus[((Subscript[η, i])->0)])),
qii===0,AppendTo[nrs,(∂_(Subscript[(OverBar[η]), i]))q]; nq=q/.(SuperPlus[((Subscript[η, i])->0)])];
CF@(Subscript[Σ, B[Most@{ri,li},bs]])[nσ,PQ[nrs,nq]/.(SuperPlus[((Subscript[η, Last@{ri,li}])->(Subscript[η, First@{ri,li}]))])]  ]

c for contract:

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{li___,i_,ri___},{___,j_,___},___]])[__]:=t//(Subscript[FM, j,First@{ri,li}])//(Subscript[Cordon, j])

(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,i_,j_,___},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{j_,___,i_},___]])[__]:=(Subscript[Cordon, j])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{___,j_,i_,___},___]])[__]:=(Subscript[Cordon, i])@t
(Subscript[c, i_,j_])@t:(Subscript[Σ, B[{i_,___,j_},___]])[__]:=(Subscript[Cordon, i])@t

mc for magnetic contract:

mc[ℰ_]:=ℰ//.
t:(Subscript[Σ, B[{___,i_,___},{___,j_,___},___]])[__]|(Subscript[Σ, B[{___,i_,j_,___},___]])[__]|(Subscript[Σ, B[{j_,___,i_},___]])[__]/;i+j==0:>(Subscript[c, i,j])@t

Kas[P[i_,j_]]:=CF@(Subscript[Σ, B[{-i,j}]])[0,PQ[{},0]];
TL[P[i_,j_]]:=CF@(Subscript[Σ, B[{-i,j}]])[0,PQ[{},0]]

Kas[x:X[i_,j_,k_,l_]]:=Kas@If[PositiveQ[x],
(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
Kas[x:((SubPlus[X])|(SubMinus[X]))[__]]:=Module[{v=2(u^2)-1,p,fs,ηs,m},
ηs=(Subscript[η, #])&/@(fs=List@@x);p=Head[x]===(SubPlus[X]);
m=If[p,(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}})),-(({{v, u, 1, u}, {u, 1, u, 1}, {1, u, v, u}, {u, 1, u, 1}}))];
CF@(Subscript[Σ, B[fs]])[If[p,-1,1],PQ[{},(SuperStar[ηs]).m.ηs]]]

Kas/@{(SubPlus[X])[1,2,3,4],(SubMinus[X])[1,4,3,2]}

TL[x:X[i_,j_,k_,l_]]:=TL@If[PositiveQ[x],
(SubPlus[X])[-i,j,k,-l],(SubMinus[X])[-j,k,l,-i]];
TL[x:((SubPlus[X])|(SubMinus[X]))[__]]:=Module[{t=1-ω,r,p,fs,ηs,m},
r=t+(SuperStar[t]);ηs=(Subscript[η, #])&/@(fs=List@@x);p=Head[x]===(SubPlus[X]);
m=If[p,(({{-r, -t, 2 t, (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {2 (SuperStar[t]), t, -r, -(SuperStar[t])}, {t, 0, -t, 0}})),(({{r, -t, -2 (SuperStar[t]), (SuperStar[t])}, {-(SuperStar[t]), 0, (SuperStar[t]), 0}, {-2t, t, r, -(SuperStar[t])}, {t, 0, -t, 0}}))];
CF@(Subscript[Σ, B[fs]])[0,PQ[{},(SuperStar[ηs]).m.ηs]]]

TL/@{X[1,2,3,4],X[1,4,3,2]}

Kas[K_]:=Fold[mc[#1⋃#2]&,(Subscript[Σ, B[]])[0,PQ[{},0]], List@@(Kas/@PD@K)];
KasSig[K_]:=Expand[Kas[K][[1]]/2]

Kas[Knot[3,1]]

KasSig[Knot[3,1]]

TL[K_]:=Fold[mc[#1⋃#2]&,(Subscript[Σ, B[]])[0,PQ[{},0]], List@@(TL/@PD@K)]/.θ[c_+u]/;Abs[c]>=1:>θ[c];
TLSig[K_]:=TL[K][[1]]

TLSig[Knot[3,1]]

Reidemeister 2

Kas[X[1,5,2,4]]⋃Kas[X[2,5,3,6]]

Kas[X[1,5,2,4]]⋃Kas[X[2,5,3,6]]//(Subscript[FM, 5,-2])

Kas[X[1,5,2,4]]⋃Kas[X[2,5,3,6]]//(Subscript[FM, 5,-2])//(Subscript[Cordon, -2])

Kas[X[1,5,2,4]]⋃Kas[X[2,5,3,6]]//(Subscript[FM, -2,5])//(Subscript[Cordon, 5])//(Subscript[Cordon, -2])

{Kas[P[1,3]]⋃Kas[P[4,6]]//(Subscript[FM, -4,3]), Kas[X[1,5,2,4]]⋃Kas[X[2,5,3,6]]//mc}

{TL[P[1,3]]⋃TL[P[4,6]]//(Subscript[FM, -4,3]), TL[X[1,5,2,4]]⋃TL[X[2,5,3,6]]//mc}

Reidemeister 3

lhs=Kas[X[4,2,5,1]]⋃Kas[X[7,3,8,2]]⋃Kas[X[8,6,9,5]]//mc;
rhs=Kas[X[7,5,8,4]]⋃Kas[X[8,2,9,1]]⋃Kas[X[5,3,6,2]]//mc
{lhs[[1]],rhs[[1]]}
Simplify[lhs[[2,2]]==rhs[[2,2]]]

f=KasSig@PD[X[4,2,5,1],X[7,3,8,2],X[8,6,9,5]];
Plot[f,{u,-1.2,1.2}]

lhs=TL[X[4,2,5,1]]⋃TL[X[7,3,8,2]]⋃TL[X[8,6,9,5]]//mc;
rhs=TL[X[7,5,8,4]]⋃TL[X[8,2,9,1]]⋃TL[X[5,3,6,2]]//mc
{lhs[[1]],rhs[[1]]}
lhs[[2,2]]==rhs[[2,2]]

f=TLSig@PD[X[4,2,5,1],X[7,3,8,2],X[8,6,9,5]];
Plot[f,{u,-1.2,1.2}]

Kashaev for Knots

-KnotSignature/@AllKnots[{3,8}]

(*u=0;*)
Kas[Knot[3,1]]
Clear[u]

(Subscript[Σ, B[]])[sign[(1/2) (3-4 (u^2))]+sign[-2 (-1+2 (u^2))]+sign[-((-3+4 (u^2))/(-1+2 (u^2)))],PQ[{},0]]

Table[K->2KasSig[K],{K,AllKnots[{3,7}]}]//Column

f=KasSig[Knot[10,1]]
Plot[f,{u,-1,1}]

f=TLSig[Knot[10,1]]
Plot[f,{u,-1,1}]

(KasSig/@AllKnots[{3,8}])/.u->1/2

f=KasSig[Knot[9,5]]
Plot[f,{u,-1,1}]

f=TLSig[Knot[9,5]]
Plot[f,{u,-1,1}]

f=KasSig[Knot[8,2]]
Plot[f,{u,-1,1}]

f=TLSig[Knot[8,2]]
Plot[f,{u,-1,1}]

f=KasSig[Knot[12,Alternating,422]]
Plot[f,{u,-1,1}]

f=TLSig[Knot[12,Alternating,422]]
Plot[f,{u,-1,1}]

Tristram-Levine for Knots

-KnotSignature/@AllKnots[{3,8}]

TL[Knot[3,1]]

TLSig/@AllKnots[{3,8}] /. u->0

TLSig/@AllKnots[{3,8}] /. u->0.9999

Table[K->TLSig[K],{K,AllKnots[{3,8}]}]//Column

Some Tangles

The ``first’’ tangle $T_1$.

The  Conway-Kinoshita-Terasaka Tangles.

T2=PD[X[1,6,2,7],X[7,2,8,3],X[3,8,4,9],X[11,6,12,5],X[4,11,5,10]];
T3=PD[X[6,2,7,1],X[2,8,3,7],X[8,4,9,3],X[5,12,6,13],X[11,4,12,5],X[14,10,15,11],X[9,15,10,16]];

{TL[T2],Kas[T2]}

{TL[T3],Kas[T3]}

Non-trivial codimension examples.

{B1,B2}={PD[X[5,2,6,1],X[2,8,3,9],X[11,4,12,3],X[12,10,13,9],X[6,13,7,14]],PD[X[5,2,6,1],X[2,8,3,9],X[11,4,12,3],X[12,10,13,9],X[13,7,14,6]]};

{TL[B1],Kas[B1]}

{TL[B2],Kas[B2]}