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

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

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

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

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

RuleOf/@CF[{(Subscript[η, 1])-(Subscript[η, 2]),(Subscript[η, 1])-(Subscript[η, 3]),(Subscript[η, 4])}]

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

CF[Kas[b_,σ_,pq_]]:=Kas[CF[b],σ,CF[pq]]

The disjoint union in the world of multi-tangles.

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

Kas[P[1,2]]⋃Kas[P[3,4]]

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

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

(Subscript[Cordon, i_])@Kas[Bndry[{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[TrueQ[qii==0],
AppendTo[nrs,(∂_(Subscript[η, i]))q]; nq=q/.(Subscript[η, i])->0,
(*else*) nσ+=Sign[qii];nq=q/.(Subscript[η, i])->((-((∂_(Subscript[η, i]))q)/.(Subscript[η, i])->0)/qii)],
(*else*){p}=FirstPosition[(#==0)&/@ϕ,False];
{nrs,nq}={rs,q}/.(Subscript[η, i])->((-rs[[p]]/.(Subscript[η, i])->0)/((∂_(Subscript[η, i]))(rs[[p]])))];
CF@Kas[Bndry[Rest@{ri,li},bs],nσ,PQ[nrs,nq]/.(Subscript[η, ai])->(Subscript[η, bi])]  ]

(Subscript[c, i_,j_])@Kas[Bndry[{li___,i_,ri___},{lj___,j_,rj___},bs___],σ_,pq_PQ]:=Module[{bi=Last@{ri,li}},
Kas[Bndry[{li,i,ri},{lj,j,rj},bs],σ,pq]//(Subscript[FM, j,bi])//(Subscript[Cordon, j])  ];

(Subscript[c, i_,j_])@Kas[Bndry[{l___,i_,j_,r___},bs___],σ_,pq_PQ]:=(Subscript[Cordon, i])@Kas[Bndry[{l,i,j,r},bs],σ,pq];
(Subscript[c, i_,j_])@Kas[Bndry[{j_,m___,i_},bs___],σ_,pq_PQ]:=(Subscript[Cordon, i])@Kas[Bndry[{j,m,i},bs],σ,pq];
(Subscript[c, i_,j_])@Kas[Bndry[{l___,j_,i_,r___},bs___],σ_,pq_PQ]:=(Subscript[Cordon, j])@Kas[Bndry[{l,j,i,r},bs],σ,pq];
(Subscript[c, i_,j_])@Kas[Bndry[{i_,m___,j_},bs___],σ_,pq_PQ]:=(Subscript[Cordon, j])@Kas[Bndry[{i,m,j},bs],σ,pq];

c@Kas[Bndry[{li___,i_,ri___},{lj___,j_,rj___},bs___],σ_,pq_PQ]/;j==-i:=c[(Subscript[c, i,j])@Kas[Bndry[{li,i,ri},{lj,j,rj},bs],σ,pq]];
c@Kas[Bndry[{l___,i_,j_,r___},bs___],σ_,pq_PQ]/;j==-i:=c@(Subscript[Cordon, i])@Kas[Bndry[{l,i,j,r},bs],σ,pq];
c@Kas[Bndry[{j_,m___,i_},bs___],σ_,pq_PQ]/;j==-i:=c@(Subscript[Cordon, i])@Kas[Bndry[{j,m,i},bs],σ,pq];
c@Kas[b_Bndry,σ_,pq_PQ]/;(Union@@b⋂(-Union@@b))==={}:=Kas[b,σ,pq]

Kas[P[i_,j_]]:=Kas[CF@Bndry[{-i,j}], 0,PQ[{},0]]

v:=2(u^2)-1;

Kas[X[i_,j_,k_,l_]]:=If[PositiveQ@X[i,j,k,l],
Kas[CF@Bndry[{-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)]],
Kas[CF@Bndry[{-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]]//(Subscript[c, 2,-2])//(Subscript[c, 5,-5])}

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]

Kas[Bndry[{-7,3,6,9,-1,-4}],-1,PQ[{},((1486 (Subscript[η, -7]^2))/645)+((32578 (Subscript[η, -7]) (Subscript[η, -4]))/18705)+((228046 (Subscript[η, -4]^2))/542445)+(1682/645) (Subscript[η, -7]) (Subscript[η, -1])+((32578 (Subscript[η, -4]) (Subscript[η, -1]))/18705)+((228046 (Subscript[η, -1]^2))/542445)+((32578 (Subscript[η, -7]) (Subscript[η, 3]))/18705)+(1682/645) (Subscript[η, -4]) (Subscript[η, 3])+(812/645) (Subscript[η, -1]) (Subscript[η, 3])+((228046 (Subscript[η, 3]^2))/542445)+(1682/645) (Subscript[η, -7]) (Subscript[η, 6])+(812/645) (Subscript[η, -4]) (Subscript[η, 6])+(1682/645) (Subscript[η, -1]) (Subscript[η, 6])+((32578 (Subscript[η, 3]) (Subscript[η, 6]))/18705)+((228046 (Subscript[η, 6]^2))/542445)+(812/645) (Subscript[η, -7]) (Subscript[η, 9])+(1682/645) (Subscript[η, -4]) (Subscript[η, 9])+((32578 (Subscript[η, -1]) (Subscript[η, 9]))/18705)+((1682 (Subscript[η, 3]) (Subscript[η, 9]))/645)+((32578 (Subscript[η, 6]) (Subscript[η, 9]))/18705)+((1486 (Subscript[η, 9]^2))/645)]]

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

Kashaev for Knots

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

(*Kas[{k1_Kas, ks__Kas}]:=Module[{k2},
k2=First@MaximalBy[{ks},Length[(-k1[[1,1]])⋂#[[1,1]]]&];
Kas@Append[DeleteCases[{ks},k2],Echo@c@(k1⋃k2)]
]//First;*)

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

u=0;
c[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]

ListPlot[Table[KasSig[Knot[9,5]],{u,-3,3,1/100}]]

ListPlot[Table[KasSig[Knot[8,2]],{u,-2,2,1/100}]]

ListPlot[Table[KasSig[Knot[12,Alternating,422]],{u,-2,2,1/100}]]

Kas[Bndry[{-15,-10,12,1}],-1,PQ[{},-((Subscript[η, -15]^2)/2)+2 (Subscript[η, -10]^2)+4 (Subscript[η, -10]) (Subscript[η, 1])+2 (Subscript[η, 1]^2)+(Subscript[η, -15]) (Subscript[η, 12])-((Subscript[η, 12]^2)/2)]]⋃Kas[Bndry[{-12,10,15,-1}],1,PQ[{},((11 (Subscript[η, -12]^2))/13)-((13 (Subscript[η, -1]^2))/11)+(26/11) (Subscript[η, -1]) (Subscript[η, 10])-((13 (Subscript[η, 10]^2))/11)+(22/13) (Subscript[η, -12]) (Subscript[η, 15])+((11 (Subscript[η, 15]^2))/13)]]

Kas[Bndry[{-15,-10,12,1},{-12,10,15,-1}],0,PQ[{},-((Subscript[η, -15]^2)/2)+((11 (Subscript[η, -12]^2))/13)+2 (Subscript[η, -10]^2)-((13 (Subscript[η, -1]^2))/11)+4 (Subscript[η, -10]) (Subscript[η, 1])+2 (Subscript[η, 1]^2)+(26/11) (Subscript[η, -1]) (Subscript[η, 10])-((13 (Subscript[η, 10]^2))/11)+(Subscript[η, -15]) (Subscript[η, 12])-((Subscript[η, 12]^2)/2)+(22/13) (Subscript[η, -12]) (Subscript[η, 15])+((11 (Subscript[η, 15]^2))/13)]]//(Subscript[c, 15,-15])//(Subscript[c, 10,-10])//(Subscript[c, 12,-12])//(Subscript[c, 1,-1])