Pensieve header: Kauffman States for tangles.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2024-03"];
Once[<< KnotTheory`];

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

SetAttributes[{B,M}, Orderless]; (* B for Boundary, M for Marked *)
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]])[Expand[f1 f2]/.{M[m1___]M[m2___]:>M[m1,m2], ((M[])^2)->M[]}];

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/.{
M[i,j,___]->0,M[i|j,ms___]:>M[i,j,ms],M[ms___]:>M[i,ms]+M[j,ms]
}]

(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
/.{M[i,ms___]:>M[ms],M[___]->0}
/.{M[j1,j2,___]->0,M[j2,ms___]:>M[j1,ms]}
]
]

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}]])[M[]];
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}]])[μ (T^(-1))M[i]+T M[k]+M[l]+M[j]];
KSI[(Subscript[(OverBar[X]), i_,j_,k_,l_])]:=CF@(Subscript[G, B[{i,j,k,l}]])[μ T M[i]+(T^(-1))M[k]+M[l]+M[j]];
KSI[K_]:=Fold[mc[#1⊕#2]&,(Subscript[G, B[]])[1],List@@(KSI/@PD@K)];

Knots

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]}
];
KSIK[K_]:=KSI[Cut@PD@K][[1]]/.{M[]->1,T->(T^(1/2)),μ->-1}

Collect[KSI[Cut@PD@Knot[8,17]][[1]]/.M[]->1,μ, Expand]

KSIK[Knot[8,17]]

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

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

Reidemeister 2

lhs=CF[KSI@PD[(Subscript[X, -2,4,3,-1]),(Subscript[(OverBar[X]), -4,6,5,-3])]]

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

lhs[[1]]-rhs[[1]] /. μ->-1

Reidemeister 3

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

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

Collect[lhs[[1]]-rhs[[1]],μ]

lhs[[1]]-rhs[[1]] /. μ->-1

Tree Counts

TC[K_]:=KSI[Cut@PD@K][[1]]/.{M[]->1, T->1,μ->1}

TC[Knot[3,1]]

TC/@AllKnots[{3,9}]

MaximalBy[AllKnots[{3,9}],TC]

MaximalBy[AllKnots[{3,10}],TC]

TC[Knot[10,123]]

TC[TorusKnot[5,3]]

TC[TorusKnot[7,3]]

TC[TorusKnot[8,3]]

KSIK[TorusKnot[8,3]]

TC[TorusKnot[7,4]]

KSIK[TorusKnot[7,4]]