Pensieve header: Kauffman States for tangles.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2024-03"];
Once[<< KnotTheory`];
Cut[pd_PD]:=Module[{n=Length[pd]},
pd/.{X[2n,i_,1,j_]:>X[2n,i,2n+1,j],X[i_,1,j_,2n]:>X[i,2n+1,j,2n],X[i_,2n,j_,1]:>X[i,2n,j,2n+1]}
]

CF[ℰ_]:=Expand[ℰ];

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

CF[(Subscript[G, b_])[f_]]:=(Subscript[G, CF[b]])[CF[f]]

(Subscript[G, b1_])[f1_]⊕(Subscript[G, b2_])[f2_]^:=CF@(Subscript[G, Join[b1,b2]])[f1 f2];

GT for Gap Touch:

(Subscript[GT, i_,j_])@(Subscript[G, B[{li___,i_,ri___},{lj___,j_,rj___},bs___]])[f_]:=CF@(Subscript[G, B[{ri,li,j,rj,lj,i},bs]])[f/.{
(Subscript[Y, i])[l1___](Subscript[Y, j])[l2___]:>Sort@(Subscript[Y, i])[j,l1,l2]+Sort@(Subscript[Y, j])[i,l1,l2],
(Subscript[Y, i])[l1___](Subscript[Y, k_])[ll___,j,rl___]:>Sort@(Subscript[Y, k])[l1,ll,rl,i,j],
(Subscript[Y, i])[l1___]Y[ll___,j,rl___]:>Sort@Y[l1,ll,rl,i,j],
(Subscript[Y, j])[l1___](Subscript[Y, k_])[ll___,i,rl___]:>Sort@(Subscript[Y, k])[l1,ll,rl,i,j],
(Subscript[Y, j])[l1___]Y[ll___,i,rl___]:>Sort@Y[l1,ll,rl,i,j],
(Subscript[Y, _])[___,i,___](Subscript[Y, _])[___,j,___]->0,
(Subscript[Y, _])[___,i,___]Y[___,j,___]->0,
(Subscript[Y, _])[___,j,___]Y[___,i,___]->0,
Y[___,i,___]Y[___,j,___]->0
}]

(Subscript[Cordon, i_])@(Subscript[G, B[{li___,i_,ri___},bs___]])[f_]:=Module[{j1,j2},
{j1,j2}={First@{ri,li},Last@{ri,li}};
CF@(Subscript[G, B[Most@{ri,li},bs]])[f/.{
(Subscript[Y, i])[l___]->0,
(Subscript[Y, k_])[ll___,i,rl___]:>(Subscript[Y, k])[ll,rl],
Y[ll___,i,rl___]:>Y[ll,rl]
}/.{
(Subscript[Y, j1])[l1___](Subscript[Y, j2])[l2___]:>Sort@(Subscript[Y, j1])[l1,l2],
(Subscript[Y, j1])[___,j2,___]->0,
(Subscript[Y, j2])[___,j1,___]->0,
(Subscript[Y, j1])[ls___](Subscript[Y, k_])[ll___,j2,rl___]:>Sort@(Subscript[Y, k])[j1,ls,ll,rl],
(Subscript[Y, j2])[ls___](Subscript[Y, k_])[ll___,j1,rl___]:>Sort@(Subscript[Y, k])[j1,ls,ll,rl],
(Subscript[Y, j1])[ls___]Y[ll___,j2,rl___]:>Sort@Y[j1,ls,ll,rl],
(Subscript[Y, j2])[ls___]Y[ll___,j1,rl___]:>Sort@Y[j1,ls,ll,rl],
(Subscript[Y, _])[___,j1,___](Subscript[Y, _])[___,j2,___]->0,
(Subscript[Y, _])[___,j2,___]Y[___,j1,___]->0,
Y[___,j1,___]Y[___,j2,___]->0,
(Subscript[Y, _])[___,j1,___,j2,___]->0,
(Subscript[Y, _])[___,j2,___,j1,___]->0,
Y[___,j1,___,j2,___]->0,
Y[___,j2,___,j1,___]->0
}]
]

Strand Operations. c for contract, mc for magnetic contract:

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

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

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

“KSI” for Kauffman States Invariant.

KSI@(Subscript[P, i_,j_]):=CF@(Subscript[G, B[{i,j}]])[(Subscript[Y, i])[](Subscript[Y, j])[]];
KSI[x:X[i_,j_,k_,l_]]:=KSI@If[PositiveQ[x],(Subscript[X, -i,j,k,-l]),(Subscript[(OverBar[X]), -j,k,l,-i])];
KSI[(Subscript[X, i_,j_,k_,l_])]:=CF@(Subscript[G, B[{i,j,k,l}]])[m (T^(-1))(Subscript[Y, k])[i](Subscript[Y, j])[](Subscript[Y, l])[]+T (Subscript[Y, i])[k](Subscript[Y, j])[](Subscript[Y, l])[]+(Subscript[Y, j])[l](Subscript[Y, i])[](Subscript[Y, k])[]+(Subscript[Y, l])[j](Subscript[Y, i])[](Subscript[Y, k])[]];
KSI[(Subscript[(OverBar[X]), i_,j_,k_,l_])]:=CF@(Subscript[G, B[{i,j,k,l}]])[m T (Subscript[Y, k])[i](Subscript[Y, j])[](Subscript[Y, l])[]+(T^(-1))(Subscript[Y, i])[k](Subscript[Y, j])[](Subscript[Y, l])[]+(Subscript[Y, j])[l](Subscript[Y, i])[](Subscript[Y, k])[]+(Subscript[Y, l])[j](Subscript[Y, i])[](Subscript[Y, k])[]];
KSI[K_]:=Fold[mc[#1⊕#2]&,(Subscript[G, B[]])[1],List@@(KSI/@PD@K)];

Knots

KSIK[K_]:=KSI[Cut@PD@K][[1]]/.{(Subscript[Y, _])[]->1, T->(T^(1/2)),m->-1}

KSIK[Knot[8,17]]

Alexander[Knot[8,17]][T]

Monitor[
Timing@Table[res=(K->((KSIK[K])/(Alexander[K][T]))),{K,AllKnots[{3,10}]}],
res]

Reidemeister 2

CF[KSI@PD[(Subscript[X, -2,4,3,-1]),(Subscript[(OverBar[X]), -4,6,5,-3])]/.m->-1]

(Subscript[GT, 5,-2])@KSI@PD[(Subscript[P, -1,5]),(Subscript[P, -2,6])]

Reidemeister 3

lhs=KSI[PD[(Subscript[X, -2,5,4,-1]),(Subscript[X, -3,7,6,-5]),(Subscript[X, -6,9,8,-4])]] /. m->-1

rhs=KSI[PD[(Subscript[X, -3,5,4,-2]),(Subscript[X, -4,6,8,-1]),(Subscript[X, -5,7,9,-6])]] /. m->-1

lhs[[1]]-rhs[[1]]