Pensieve header: For Luke Seaton.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\KnotTheoryCongress-2502"];

Once[<<KnotTheory`; <<Rot.m; << PolyPlot.m];

CableComponent from https://katlas.org/wiki/CableComponent.m:

CableComponent[BR[n_Integer,js_List],K_]:=Module[{BC,C0,C1,C2,CC1,CS1,CS2,L,S,a,e,h,i,i1,i2,j,j1,j2,jss,k,k1,kjs,out,out0,out1,p,p1,pos,q,r,s,ss,t,t0,t1,t2,tj,v,w,writhe},L=PD[K];
kjs=BR[L][[2]];
For[i1=1;writhe=0,i1<=Length[kjs],i1++,writhe=writhe+Sign[kjs[[i1]]]];
For[i2=1;jss[0]=js,i2<=n Abs[writhe],i2++,jss[i2]=Flatten[{jss[i2-1],Table[-Sign[writhe] e,{e,n-1}]}]];
k1=Length[jss[n Abs[writhe]]];
For[i=1,i<=n,i++,s[i]=a[i]=i];
For[j=1,j<=k1,j++,p=Select[Range[n],Abs[jss[n Abs[writhe]][[j]]]==a[#]&][[1]];
q=Select[Range[n],a[#]==a[p]+1&][[1]];
If[jss[n Abs[writhe]][[j]]>0,K[j]=X[s[q],n+2 j,n+2 j-1,s[p]],K[j]=X[s[p],s[q],n+2 j,n+2 j-1]];
s[p]=n+2 j;
s[q]=n+2 j-1;
a[p]++;
a[q]--];
BC=Table[K[d],{d,k1}];
If[Jones[L][q]===1,For[j1=1,j1<=Length[BC],j1++,For[i=1,i<=n,i++,BC[[j1]]=BC[[j1]]/. s[i]:>a[i]]];
If[BC=={},BC={Loop[1]}];
out1=PD@@BC,For[j2=1,j2<=Length[BC],j2++,For[tj=1,tj<=n,tj++,BC[[j2]]=BC[[j2]]/. tj:>1[tj]]];
p1=Select[Range[n],#!=s[#]&];
S=Select[L,MemberQ[#,1]&&MemberQ[#,2]&];
pos=Position[S,1][[1,2]];
r=Select[Table[i,{i,Length[L]}],L[[#]]==Flatten@@S&][[1]];
k=0;
out0=L/. X[a_,b_,c_,d_]:>(++k;
Table[X[h[i,j-1,k],v[i,j,k],h[i,j,k],v[i-1,j,k]],{i,n},{j,n}]/. {h[i_,0,_]:>a[i],h[i_,n,_]:>c[i]}/. If[d-b==1||b-d>1,{v[0,j_,_]:>d[j],v[n,j_,_]:>b[j]},{v[0,j_,_]:>d[n+1-j],v[n,j_,_]:>b[n+1-j]}]);
w=Flatten@out0[[r]];
out=PD@@Flatten[Join@@out0];
ss=Table[a[i],{i,n}][[p1]];
CC1=List@@out;
For[t0=1,t0<=Length[ss],t0++,C0[t0]=Select[w,MemberQ[#,1[ss[[t0]]]]&];
C1[t0]=Select[C0[t0],Mod[Position[#,1[ss[[t0]]]][[1,1]],2]==Mod[pos,2]&];
C2[t0]=C1[t0]/. 1[ss[[t0]]]:>s[Select[Range[n],a[#]==ss[[t0]]&][[1]]]];
CS1=Flatten[Table[C1[t1],{t1,Length[ss]}]];
CS2=Flatten[Table[C2[t2],{t2,Length[ss]}]];
For[i=1,i<=Length[CS1],i++,CC1=DeleteCases[CC1,CS1[[i]]]];
out1=Union[BC,CC1,CS2];
PD@@out1;
k=0;
out1=PD@@(out1/. ((#->++k)&/@(List@@Union@@out1)))]];

(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);

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

(Subscript[F, 1])[{s_,i_,j_}]=CF[s(1/2-(Subscript[g, 3,i,i])+(Subscript[T, 2]^s)(Subscript[g, 1,i,i])(Subscript[g, 2,j,i])-(Subscript[g, 1,i,i])(Subscript[g, 2,j,j])-((Subscript[T, 2]^s)-1)(Subscript[g, 2,j,i])(Subscript[g, 3,i,i])+2(Subscript[g, 2,j,j])(Subscript[g, 3,i,i])-(1-(Subscript[T, 3]^s))(Subscript[g, 2,j,i])(Subscript[g, 3,j,i])-(Subscript[g, 2,i,i])(Subscript[g, 3,j,j])-(Subscript[T, 2]^s)(Subscript[g, 2,j,i])(Subscript[g, 3,j,j])+(Subscript[g, 1,i,i])(Subscript[g, 3,j,j])+(((Subscript[T, 1]^s)-1)(Subscript[g, 1,j,i])((Subscript[T, 2]^(2s))(Subscript[g, 2,j,i])-(Subscript[T, 2]^s)(Subscript[g, 2,j,j])+(Subscript[T, 2]^s)(Subscript[g, 3,j,j]))+((Subscript[T, 3]^s)-1)(Subscript[g, 3,j,i])(1-(Subscript[T, 2]^s)(Subscript[g, 1,i,i])-((Subscript[T, 1]^s)-1)((Subscript[T, 2]^s)+1) (Subscript[g, 1,j,i])+((Subscript[T, 2]^s)-2)(Subscript[g, 2,j,j])+(Subscript[g, 2,i,j])))/((Subscript[T, 2]^s)-1))];

(Subscript[F, 2])[{s0_,i0_,j0_},{s1_,i1_,j1_}]:=CF[s1((Subscript[T, 1]^s0)-1)((((Subscript[T, 2]^s1)-1))^(-1))((Subscript[T, 3]^s1)-1)(Subscript[g, 1,j1,i0])(Subscript[g, 3,j0,i1])( ((Subscript[T, 2]^s0)(Subscript[g, 2,i1,i0])-(Subscript[g, 2,i1,j0]))- ((Subscript[T, 2]^s0)(Subscript[g, 2,j1,i0])-(Subscript[g, 2,j1,j0])))]

(Subscript[F, 3])[φ_,k_]=-φ/2+φ (Subscript[g, 3,k,k]);

Θ[K_]:=Θ[K]=Module[{Cs,φ,n,A,Δ,G,ev,θ},
{Cs,φ}=Rot[K]; n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G=Inverse[A];
ev[ℰ_]:=Factor[ℰ/.(Subscript[g, ν_,α_,β_]):>(G[[α,β]]/.T->(Subscript[T, ν]))];
θ=ev[(∑_(k=1)^n)(Subscript[F, 1])[Cs[[k]]]];
θ+=ev[(∑_(k1=1)^n)(∑_(k2=1)^n)(Subscript[F, 2])[Cs[[k1]],Cs[[k2]]]];

θ+=ev[(∑_(k=1)^(2n))(Subscript[F, 3])[φ[[k]],k]];
Factor@{Δ,(Δ/.T->(Subscript[T, 1]))(Δ/.T->(Subscript[T, 2]))(Δ/.T->(Subscript[T, 3]))θ}];

Θ[Knot[3,1]]

Knot[3,1]//PD

K=CableComponent[BR[4,{1,2,3}], Knot[3,1]]

skel=Skeleton[K]

inds=Flatten[List@@@skel]

Thread[inds->Range[Length[inds]]]

CF[pd_PD]:=Module[{skel,inds},
skel=Skeleton[K];
inds=Flatten[List@@@skel];
pd/.Thread[inds->Range[Length[inds]]]
]

Θ[CF@K]

Θ[CF@K]//PolyPlot