SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Theta"];
Once[<<Theta.m]
SetOptions[PolyPlot,ImageSize->Tiny];
Clear[Θ]

RandomVK[n_]:={
Prepend[#,2RandomInteger[1]-1]&/@Partition[PermutationList[RandomPermutation[2n],2n],2],
Table[RandomInteger[{-1,1}],2n+1]
};

RandomVK[5]

CF[ℰ_] := Expand@Collect[ℰ,(Subscript[g, __])|(Subscript[χ, __]),F]/.F->Factor@*PowerExpand;

Short[Options[Θ]={F1->(F1i=(Subscript[F, 1])[{s0,i0,j0}]), F2->(F2i=(Subscript[F, 2])[{s0,i0,j0},{s1,i1,j1}]), F3->(F3i=(Subscript[F, 3])[φ,k])}]

Θ[K_,opts___Rule]:=Module[{X,φφ,n,A,Δ,G,ev,θ,kk,k0,k1,f1,f2,f3},
f1=F1/.{opts}/.Options[Θ];
f2=F2/.{opts}/.Options[Θ];
f3=F3/.{opts}/.Options[Θ];
{X,φφ}=Rot[K]; n=Length[X]; A=IdentityMatrix[2n+1];
Cases[X,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ=(T^((-Total[φφ]-Total[X[[All,1]]])/2))Det[A];
G=Inverse[A];
ev[ℰ_]:=Factor[ℰ/.{(SuperPlus[k_]):>k+1,$->2n+1}/.
{(Subscript[g, α_,β_]):>G[[α,β]],(Subscript[g, ν_,α_,β_]):>(G[[α,β]]/.T->(Subscript[T, ν]))}];
θ=ev@Sum[f1/.Thread[{s0,i0,j0}->X[[kk]]], {kk,n}];
θ+=ev@Sum[f2/.Thread[{s0,i0,j0}->X[[k0]]]//.Thread[{s1,i1,j1}->X[[k1]]], {k0,n}, {k1,n}];
θ+=ev@Sum[f3/.{φ->φφ[[kk]],k->kk}, {kk,Length@φφ}];
Factor@{Δ,(Δ/.T->(Subscript[T, 1]))(Δ/.T->(Subscript[T, 2]))(Δ/.T->(Subscript[T, 3]))θ}
];

K1=Knot[7,6];
K1// Rot
K1//Θ
K1//Θ//PolyPlot

PolyPlot/@{Θ[K1],Θ[K1, F3->0]}

(Subscript[χ, True])=1; (Subscript[χ, False])=0;
(Subscript[χ, α_<=α_])=1;(Subscript[χ, ph_]^(p_))/;p>1^:=(Subscript[χ, ph]); (Subscript[χ, α_==β_])/;OrderedQ[{β,α}]:=(Subscript[χ, β==α]);
(Subscript[χ, (SuperPlus[α_])==(SuperPlus[β_])]):=(Subscript[χ, α==β]);
(Subscript[δ, i_,j_]):=(Subscript[χ, i==j]);

gRules[{s_,i_,j_}]:={(Subscript[g, ν_,j,β_]):>(Subscript[g, ν,(SuperPlus[j]),β])+(Subscript[δ, j,β]),(Subscript[g, ν_,i,β_]):>(Subscript[T, ν]^s)(Subscript[g, ν,(SuperPlus[i]),β])+(1-(Subscript[T, ν]^s))(Subscript[g, ν,(SuperPlus[j]),β])+(Subscript[δ, i,β]),
(Subscript[g, ν_,α_,(SuperPlus[i])]):>(Subscript[T, ν]^s)(Subscript[g, ν,α,i])+(Subscript[δ, α,(SuperPlus[i])]),(Subscript[g, ν_,α_,(SuperPlus[j])]):>(Subscript[g, ν,α,j])+(1-(Subscript[T, ν]^s))(Subscript[g, ν,α,i])+(Subscript[δ, α,(SuperPlus[j])]),
(Subscript[g, j,β_]):>(Subscript[g, (SuperPlus[j]),β])+(Subscript[δ, j,β]),(Subscript[g, i,β_]):>(T^s)(Subscript[g, (SuperPlus[i]),β])+(1-(T^s))(Subscript[g, (SuperPlus[j]),β])+(Subscript[δ, i,β]),
(Subscript[g, α_,(SuperPlus[i])]):>(T^s)(Subscript[g, α,i])+(Subscript[δ, α,(SuperPlus[i])]),(Subscript[g, α_,(SuperPlus[j])]):>(Subscript[g, α,j])+(1-(T^s))(Subscript[g, α,i])+(Subscript[δ, α,(SuperPlus[j])])
};
bRules[{s_,i_,j_}]:={ (* b for "push indices backwards" *)
(Subscript[g, (SuperPlus[j]),β_]):>(Subscript[g, j,β])-(Subscript[δ, j,β]),(Subscript[g, (SuperPlus[i]),β_]):>(T^(-s))(Subscript[g, i,β])+(1-(T^(-s)))(Subscript[g, j,β])-(T^(-s)) (Subscript[δ, i,β])-(1-(T^(-s))) (Subscript[δ, j,β]),
(Subscript[g, α_,(SuperPlus[i])]):>(T^s)(Subscript[g, α,i])+(Subscript[δ, α,(SuperPlus[i])]),(Subscript[g, α_,(SuperPlus[j])]):>(Subscript[g, α,j])+(1-(T^s))(Subscript[g, α,i])+(Subscript[δ, α,(SuperPlus[j])]),
(Subscript[χ, (SuperPlus[i])<=β_]):>(Subscript[χ, i<=β])-(Subscript[χ, i==β]),(Subscript[χ, (SuperPlus[j])<=β_]):>(Subscript[χ, j<=β])-(Subscript[χ, j==β])
};

{(Subscript[g, i,β]),(Subscript[g, j,β])}/.gRules[{s,i,j}]

Expand[{(Subscript[g, i,β]),(Subscript[g, j,β])}/.gRules[{s,i,j}]/.bRules[{s,i,j}]]

R1=CF[Residue[(Subscript[F, 1])[{s0,i0,j0}], {(Subscript[T, 2]),1}] //.{(Subscript[T, 1])->T, (Subscript[g, 2,α_,β_]):>(Subscript[χ, α<=β]), (Subscript[g, 1|3,α_,β_]):>(Subscript[g, α,β]),(Subscript[χ, j0≤i0])->1-(Subscript[χ, i0≤j0])}]

R2=CF[Residue[(Subscript[F, 2])[{s0,i0,j0},{s1,i1,j1}], {(Subscript[T, 2]),1}] //.{(Subscript[T, 1])->T, (Subscript[g, 2,α_,β_]):>(Subscript[χ, α<=β]), (Subscript[g, 1|3,α_,β_]):>(Subscript[g, α,β])}]

Table[Θ[K,F1->R1,F2->R2,F3->0][[2]], {K,AllKnots[{3,8}]}]

Table[Θ[RandomVK[10],F1->R1,F2->R2,F3->0][[2]],30]

(Subscript[D, {s_,i_,j_}])[ℰ_]:=CF[((ℰ/.#->(SuperPlus[i]))+(ℰ/.#->(SuperPlus[j]))-(ℰ/.#->i)-(ℰ/.#->j))//.bRules[{s,i,j}]];
B[ℰ_]:=CF[((ℰ/.#->$)-(ℰ/.#->1))];

bas=List@@Expand[((Subscript[χ, #<=i0])+(Subscript[χ, #<=j0]))((Subscript[g, (SuperPlus[i0]),#])+(Subscript[g, (SuperPlus[j0]),#]))((Subscript[g, #,i0])+(Subscript[g, #,j0]))]

(B/@bas)/.{(Subscript[g, (SuperPlus[(i0|j0)]),1])->0, (Subscript[g, $,i0|j0])->0}

(Subscript[D, {s1,i1,j1}])[bas]//Short

sRules[ℰ_]:=FixedPoint[CF[#/.bRules[{s0,i0,j0}]⋃bRules[{s1,i1,j1}]⋃{
(Subscript[χ, i0==j1])->0,(Subscript[χ, i1==j0])->0,(Subscript[χ, i0==j0])->0,
(Subscript[χ, j0==j1])->(Subscript[χ, i0==i1]),
(Subscript[χ, (SuperPlus[i1])≤i0])->(Subscript[χ, i1<=i0])-(Subscript[χ, i0==i1]),(Subscript[χ, (SuperPlus[i0])==(SuperPlus[i1])])->(Subscript[χ, i0==i1]),
(Subscript[χ, i0==i1]) (Subscript[χ, i1≤i0])->(Subscript[χ, i0==i1]),(Subscript[χ, i0==i1]) (Subscript[χ, j1≤j0])->(Subscript[χ, i0==i1]),
(Subscript[χ, j0≤i0])->1-(Subscript[χ, i0≤j0]),(Subscript[χ, i1≤i0])->1-(Subscript[χ, i0≤i1])+(Subscript[χ, i1==i0]),(Subscript[χ, j1≤i0])->1-(Subscript[χ, i0<=j1])+(Subscript[χ, j1==i0]),(Subscript[χ, i1≤i0])->1-(Subscript[χ, i0≤i1])+(Subscript[χ, i1==i0]),(Subscript[χ, j1≤j0])->1-(Subscript[χ, j0≤j1])+(Subscript[χ, j1==j0]),
(Subscript[χ, i0==i1])γ_/;!FreeQ[γ,s1|i1|j1]:>(Subscript[χ, i0==i1])(γ/.{s1->s0,i1->i0,j1->j0}),
(Subscript[χ, α_==β_])(Subscript[g, β_,γ_]):>(Subscript[χ, α==β])(Subscript[g, α,γ]),(Subscript[χ, α_==β_])(Subscript[g, γ_,β_]):>(Subscript[χ, α==β])(Subscript[g, γ,α])
}]&, 
ℰ]

nulls=sRules[(Subscript[D, {s1,i1,j1}])[bas]]
Table[Θ[K,F1->0,F2->#,F3->0][[2]]& /@ nulls, {K,AllKnots[{3,8}]}]

sRules[R2]

CF[nulls/.(Subscript[χ, i0==i1])->0]

Coefficient[CF[nulls/.(Subscript[χ, i0==i1])->0], (Subscript[g, j0,i1]) (Subscript[g, j1,i0])]

CF[Coefficient[nulls, (Subscript[χ, i0==i1])]]

CF[sRules[R2]+Table[(Subscript[a, i]),{i,8}].nulls/.(Subscript[χ, i0==i1])->0]

CF[sRules[R2]+Table[(Subscript[a, i]),{i,8}].nulls/.(Subscript[χ, i0==i1])->0//.{(Subscript[a, 1|2|3|4|7|8])->0,(Subscript[a, 6])->(T^s0)-1,(Subscript[a, 5])->1-(T^s0)}]

tw=Table[(Subscript[a, i]),{i,8}].bas//.{(Subscript[a, 1|2|3|4|7|8])->0,(Subscript[a, 6])->(T^s0)-1,(Subscript[a, 5])->1-(T^s0)}

CF@sRules[R2+(Subscript[D, {s1,i1,j1}])[tw]]

R1

CF@sRules[(Subscript[χ, i0==i1])R1+R2+(Subscript[D, {s1,i1,j1}])[tw]]