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, __]),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[[α,β]]/.T->(Subscript[T, ν])),(Subscript[χ, True])->1,(Subscript[χ, False])->0}];
θ=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]))θ}
];

Θ[Knot[7,3]]

PolyPlot/@{Θ[Knot[7,3]],Θ[Knot[7,3], F3->0]}

(Subscript[δ, i_,j_]):=(Subscript[χ, i==j]); (Subscript[χ, ph_]^(p_))/;p>1^:=(Subscript[χ, ph]);
bRules[{s_,i_,j_}]:={ (* b for "push indices backwards" *)
(Subscript[g, ν_,(SuperPlus[j]),β_]):>(Subscript[g, ν,j,β])-(Subscript[δ, j,β]),(Subscript[g, ν_,(SuperPlus[i]),β_]):>(Subscript[T, ν]^(-s))(Subscript[g, ν,i,β])+(1-(Subscript[T, ν]^(-s)))(Subscript[g, ν,j,β])-(Subscript[T, ν]^(-s)) (Subscript[δ, i,β])-(1-(Subscript[T, ν]^(-s))) (Subscript[δ, j,β]),
(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])])
};
bRules[X___List]:=Union@@Table[bRules[c],{c,{X}}]

{(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}]]

(Subscript[D, {s_,i_,j_}])[ℰ_]:=CF[Expand[Plus[
ℰ/.{(Subscript[g, ν_,#,β_]):>(Subscript[g, ν,(SuperPlus[i]),β]),(Subscript[g, ν_,α_,#]):>(Subscript[g, ν,α,(SuperPlus[i])])},
ℰ/.{(Subscript[g, ν_,#,β_]):>(Subscript[g, ν,(SuperPlus[j]),β]),(Subscript[g, ν_,α_,#]):>(Subscript[g, ν,α,(SuperPlus[j])])},
-ℰ/.{(Subscript[g, ν_,#,β_]):>(Subscript[g, ν,i,β]),(Subscript[g, ν_,α_,#]):>(Subscript[g, ν,α,i])},
-ℰ/.{(Subscript[g, ν_,#,β_]):>(Subscript[g, ν,j,β]),(Subscript[g, ν_,α_,#]):>(Subscript[g, ν,α,j])}
]/.bRules[{s,i,j}] /.bRules[{s0,i0,j0}]]/. (Subscript[χ, eq_Equal]):>(Subscript[χ, Sort@eq])//.{
(Subscript[χ, j0==j1])->(Subscript[χ, i0==i1]),(Subscript[χ, (SuperPlus[j0])==(SuperPlus[j1])])->(Subscript[χ, j0==j1]),
(Subscript[χ, i0==j1])->0,(Subscript[χ, i1==j0])->0,(Subscript[χ, (SuperPlus[i0])==(SuperPlus[j1])])->0,(Subscript[χ, (SuperPlus[i0])==(SuperPlus[i1])])->(Subscript[χ, i0==i1]),(Subscript[χ, (SuperPlus[i1])==(SuperPlus[j0])])->0,(Subscript[χ, (SuperPlus[i0])==(SuperPlus[j0])])->0,
(Subscript[χ, i0==i1])A_:>(Subscript[χ, i0==i1])(A/.{s1->s0,i1->i0,j1->j0})
}/.{(Subscript[χ, i0==j0])->0,(Subscript[χ, (SuperPlus[i0])==(SuperPlus[j0])])->0,(Subscript[χ, True])->1}
];
B[ℰ_]:=CF[
(ℰ/.{(Subscript[g, ν_,#,β_]):>(Subscript[g, ν,$,β]),(Subscript[g, ν_,α_,#]):>(Subscript[g, ν,α,$])})-(ℰ/.{(Subscript[g, ν_,#,β_]):>(Subscript[g, ν,1,β]),(Subscript[g, ν_,α_,#]):>(Subscript[g, ν,α,1])})/.{
(Subscript[g, _,$,β_])->(Subscript[χ, $==β]),(Subscript[g, _,_,$])->1,(Subscript[g, _,α_,1])->(Subscript[χ, α==1])} /. {(Subscript[χ, $==i0])->0, (Subscript[χ, (SuperPlus[i0])==1])->0, (Subscript[χ, $==j0])->0,(Subscript[χ, (SuperPlus[j0])==1])->0}
];

(Subscript[D, {s1,i1,j1}])[(Subscript[g, 1,#,i0]) ]

(Subscript[D, {s1,i1,j1}])[(Subscript[g, 3,j0,#])]

B[(Subscript[g, 3,j0,#])]

tw=(Subscript[g, 1,#,i0]) ;
Θ[Knot[7,3], F1->F1i-B[tw], F2->F2i+(Subscript[D, {s1,i1,j1}])[tw]]//Echo//PolyPlot

tw=(Subscript[g, 1,j0,#]);
Θ[Knot[7,3], F1->-B[tw], F2->(Subscript[D, {s1,i1,j1}])[tw], F3->0]//Echo//PolyPlot

tw=(Subscript[g, 1,j0,#]);
Θ[Knot[7,3], F1->F1i-B[tw], F2->F2i+(Subscript[D, {s1,i1,j1}])[tw]]//Echo//PolyPlot

tw=(Subscript[g, 1,#1,j0]) (Subscript[g, 2,#1,j0]) (Subscript[g, 3,i0,#1]);
Θ[Knot[7,3], F1->-B[tw], F2->(Subscript[D, {s1,i1,j1}])[tw], F3->0]//Echo//PolyPlot
Θ[Knot[7,3], F1->F1i-B[tw], F2->F2i+(Subscript[D, {s1,i1,j1}])[tw]]//Echo//PolyPlot

bas=List@@Expand[((Subscript[g, 1,#,i0])+(Subscript[g, 1,#,j0]))((Subscript[g, 2,#,i0])+(Subscript[g, 2,#,j0]))((Subscript[g, 3,(SuperPlus[i0]),#])+(Subscript[g, 3,(SuperPlus[j0]),#]))]

Column[(#->Θ[Knot[7,3], F1->-B[#], F2->(Subscript[D, {s1,i1,j1}])[#], F3->0][[2]])&/@bas]
Column[(#->{B[#],(Subscript[D, {s1,i1,j1}])[#]})&/@bas]

tw={0,0,0,0,1,-1,0,0}.List@@Expand[((Subscript[g, 1,#,i0])+(Subscript[g, 1,#,j0]))((Subscript[g, 2,#,i0])+(Subscript[g, 2,#,j0]))((Subscript[g, 3,(SuperPlus[i0]),#])+(Subscript[g, 3,(SuperPlus[j0]),#]))]/(-1+(Subscript[T, 2]))
(Subscript[D, {s1,i1,j1}])[tw]
Θ[Knot[7,6], F1->-B[tw], F2->(Subscript[D, {s1,i1,j1}])[tw], F3->0]//Echo//PolyPlot
Θ[Knot[7,6], F1->F1i-B[tw], F2->F2i+(Subscript[D, {s1,i1,j1}])[tw]]//Echo//PolyPlot

CF[F2i+(Subscript[D, {s1,i1,j1}])[tw]]