SetDirectory["C:\\Users\\T15Roland\\Wiskunde\\Bn\\HigherRank"];
Once[<<KnotTheory`]

Rot[pd_PD]:=Module[{n,xs,x,rots,Xp,Xm,front={1},k},
n=Length@pd;rots=Table[0,{2n}];
xs=Cases[pd,x_X:>(Piecewise[{{Xp[x[[4]],x[[1]]], PositiveQ@x}, {Xm[x[[2]],x[[1]]], True}}])];
For[k=1,k<=2n,++k,
If[FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k,l_]|Xm[l_,k]:>{l+1,k+1,-l},
Xp[l_,k]|Xm[k,l_]:>(++rots[[l]];{-l,k+1,l+1}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k]];
]
];
{xs/.{Xp[i_,j_]:>{+1,i,j}, Xm[i_,j_]:>{-1,i,j}},rots} ];
Rot[K_]:=Rot[PD[K]];

CF[ℰ_] := Module[{vs=Union@Cases[ℰ,(Subscript[g, __]),∞],ps,c},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> Factor[c](Times@@(vs^ps))] ];

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

(Subscript[R, 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))];

θ[{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[Γ, 1])[φ_,k_]=-φ/2+φ (Subscript[g, 3,k,k]);

θ[K_]:=θ[K]=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ν,α,β,gEval,c,z},
{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}})))];(*A//Echo;*)
Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G=Inverse[A];
gEval[ℰ_]:=Factor[ℰ/.(Subscript[g, ν_,α_,β_]):>(G[[α,β]]/.T->(Subscript[T, ν]))];
z=gEval[(∑_(k1=1)^n)(∑_(k2=1)^n)θ[Cs[[k1]],Cs[[k2]]]];
z+=gEval[(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]]];
z+=gEval[(∑_(k=1)^(2n))(Subscript[Γ, 1])[φ[[k]],k]];
{Δ,(Δ/.T->(Subscript[T, 1]))(Δ/.T->(Subscript[T, 2]))(Δ/.T->(Subscript[T, 3]))z}//Factor ];

PolyPlot[{Δ_,θ_}]:=Module[{crs,m,m1,m2,maxc,minc,s,,rect,hex},GraphicsColumn[{
rect={{0,0},{1,0},{1,1},{0,1}};
hex=Table[{Cos[α],Sin[α]}/Cos[2π/12]/2, {α,2π/12,2π,2π/6}];
If[Expand[Δ]===0,Graphics[],
crs=CoefficientRules[(T^(m=-Exponent[Δ,T,Min]))Δ,{T}];
maxc=N@Log@Max@Abs[Last/@crs];
minc=N@Log@Min@Select[Abs[Last/@crs],#>0&];
If[minc==maxc,s[_]=0,s[c_]:=s[c]=(maxc-Log@c)/(maxc-minc)];
Graphics[crs/.({x_}->c_):>{
Lighter[Which[c==0, White,c>0, Red,c<0,Blue], 0.88s[Abs@c]],
Polygon[({x+m-1/2,0}+#)&/@rect] }, AspectRatio->1/5 ]
],
If[Expand[θ]===0,Graphics[{White,Disk[]}],
crs=CoefficientRules[(Subscript[T, 1]^(m1=-Exponent[θ,(Subscript[T, 1]),Min]))(Subscript[T, 2]^(m2=-Exponent[θ,(Subscript[T, 2]),Min]))θ,{(Subscript[T, 1]),(Subscript[T, 2])}];
maxc=N@Log@Max@Abs[Last/@crs];
minc=N@Log@Min@Select[Abs[Last/@crs],#>0&];
If[minc==maxc,s[_]=0,s[c_]:=s[c]=(maxc-Log@c)/(maxc-minc)];
Graphics[{{White,Disk[{0,0},1+Cos[2π/12]Norm[{m1,m2}]/(Sqrt[2])]},
crs/.({x1_,x2_}->c_):>{
Lighter[Which[c==0, White,c>0, Red,c<0,Blue], 0.88s[Abs@c]],
Polygon[((({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1-m1,x2-m2}+#)&/@hex] }
}]
]
},Spacings -> 0]];

(Subscript[Δ, 2])[K_]:=(Subscript[Δ, 2])[K]=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ν,α,β,gEval,c,z},
{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}})))];(*A//Echo;*)
PolynomialGCD@@Flatten[Minors[A]]
];

(Subscript[Δ, 2])[Knot[8,18]]
(Subscript[Δ, 2])[Knot[12,Alternating,427]]

Union[Length[MonomialList[Denominator[Together[θ[#][[2]]/(((Subscript[Δ, 2])[#]/.T->(Subscript[T, 1]))((Subscript[Δ, 2])[#]/.T->(Subscript[T, 2]))((Subscript[Δ, 2])[#]/.T->(Subscript[T, 3])))]]]]&/@AllKnots[{3,12}]]