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

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

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

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

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

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

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

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

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

The disjoint union in the world of multi-tangles.

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

FM for Face Merge:

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

Kas[P[1,2]]⋃Kas[P[3,4]]//(Subscript[FM, -1,4])

(Subscript[Cordon, i_])@(Subscript[TSI, B[{li___,i_,ri___},bs___]])[σ_,PQ[rs_,q_]]:=Module[{bi,ai,ϕ,nσ,nrs,nq,qii,p},
ai=First@{ri,li}; bi=Last@{ri,li};
{nσ,nrs,nq}={σ,rs,q}; ϕ=(∂_(Subscript[η, i]))rs;
If[And@@((#==0)&/@ϕ), qii=(∂_((Subscript[η, i]),(Subscript[η, i])))q;
If[qii===0,
AppendTo[nrs,(∂_(Subscript[η, i]))q]; nq=q/.(Subscript[η, i])->0,
(*else*) nσ+=Sign[qii];nq=q/.(Subscript[η, i])->-((∂_(Subscript[η, i]))q)/qii/.(Subscript[η, i])->0],
(*else*){p}=FirstPosition[(#==0)&/@ϕ,False];
{nrs,nq}={rs,q}/.(Subscript[η, i])->-rs[[p]]/ϕ[[p]]/.(Subscript[η, i])->0];
CF@(Subscript[TSI, B[Rest@{ri,li},bs]])[nσ,PQ[nrs,nq]/.(Subscript[η, ai])->(Subscript[η, bi])]  ]

c for contract:

(Subscript[c, i_,j_])@(Subscript[TSI, B[{li___,i_,ri___},{lj___,j_,rj___},bs___]])[ℰ__]:=Module[{bi=Last@{ri,li}},
(Subscript[TSI, B[{li,i,ri},{lj,j,rj},bs]])[ℰ]//(Subscript[FM, j,bi])//(Subscript[Cordon, j])  ];

(Subscript[c, i_,j_])@(Subscript[TSI, B[{l___,i_,j_,r___},bs___]])[ℰ__]:=(Subscript[Cordon, i])@(Subscript[TSI, B[{l,i,j,r},bs]])[ℰ];
(Subscript[c, i_,j_])@(Subscript[TSI, B[{j_,m___,i_},bs___]])[ℰ__]:=(Subscript[Cordon, i])@(Subscript[TSI, B[{j,m,i},bs]])[ℰ];
(Subscript[c, i_,j_])@(Subscript[TSI, B[{l___,j_,i_,r___},bs___]])[ℰ__]:=(Subscript[Cordon, j])@(Subscript[TSI, B[{l,j,i,r},bs]])[ℰ];
(Subscript[c, i_,j_])@(Subscript[TSI, B[{i_,m___,j_},bs___]])[ℰ__]:=(Subscript[Cordon, j])@(Subscript[TSI, B[{i,m,j},bs]])[ℰ];

mc for magnetic contract:

mc@(Subscript[TSI, B[{li___,i_,ri___},{lj___,j_,rj___},bs___]])[ℰ__]/;j==-i:=mc@(Subscript[c, i,j])@(Subscript[TSI, B[{li,i,ri},{lj,j,rj},bs]])[ℰ];
mc@(Subscript[TSI, B[{l___,i_,j_,r___},bs___]])[ℰ__]/;j==-i:=mc@(Subscript[Cordon, i])@(Subscript[TSI, B[{l,i,j,r},bs]])[ℰ];
mc@(Subscript[TSI, B[{j_,m___,i_},bs___]])[ℰ__]/;j==-i:=mc@(Subscript[Cordon, i])@(Subscript[TSI, B[{j,m,i},bs]])[ℰ];
mc@(Subscript[TSI, b_B])[ℰ__]/;(Union@@b⋂(-Union@@b))==={}:=(Subscript[TSI, b])[ℰ]

Kas[X[i_,j_,k_,l_]]:=With[{v=2(u^2)-1},CF@If[PositiveQ@X[i,j,k,l],
(Subscript[TSI, B[{-i,j,k,-l}]])[0,PQ[{},
(Subscript[η, -i]^2)+2 u (Subscript[η, -i]) (Subscript[η, j])+v (Subscript[η, j]^2)+2 (Subscript[η, -i]) (Subscript[η, k])+2 u (Subscript[η, j]) (Subscript[η, k])+(Subscript[η, k]^2)+2 u (Subscript[η, -i]) (Subscript[η, -l])+2 (Subscript[η, j]) (Subscript[η, -l])+2 u (Subscript[η, k]) (Subscript[η, -l])+v (Subscript[η, -l]^2)]],
(Subscript[TSI, B[{-i,-j,k,l}]])[0,PQ[{},
-v (Subscript[η, -i]^2)-2 u (Subscript[η, -i]) (Subscript[η, -j])-(Subscript[η, -j]^2)-2 (Subscript[η, -i]) (Subscript[η, k])-2 u (Subscript[η, -j]) (Subscript[η, k])-v (Subscript[η, k]^2)-2 u (Subscript[η, -i]) (Subscript[η, l])-2 (Subscript[η, -j]) (Subscript[η, l])-2 u (Subscript[η, k]) (Subscript[η, l])-(Subscript[η, l]^2)]]  ]]

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, -2,5])

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

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}

Reidemeister 3

{u=7/29};
lhs=Kas[X[4,2,5,1]]⋃Kas[X[7,3,8,2]]⋃Kas[X[8,6,9,5]]//(Subscript[c, 2,-2])//(Subscript[c, 5,-5])//(Subscript[c, 8,-8])
rhs=Kas[X[7,5,8,4]]⋃Kas[X[8,2,9,1]]⋃Kas[X[5,3,6,2]]//(Subscript[c, 2,-2])//(Subscript[c, 5,-5])//(Subscript[c, 8,-8])
Clear[u]

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]]]

lhs[[2,2]]

Kashaev for Knots

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

KasSig[K_]:=Module[{pd=PD[K]},
mc[Union@@(Kas/@pd)][[1]]-Sum[If[PositiveQ@x,1,-1],{x,List@@pd}] ]/2

(*u=0;*)
mc[Union@@(Kas/@PD@Knot[3,1])]
Clear[u]

(*u=0;*)
KasSig/@AllKnots[{3,8}]
Clear[u]

u=1/2;
KasSig/@AllKnots[{3,8}]
Clear[u]

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

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

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