SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\Theta"];

<< KnotTheory`

(* Rot suppressed *)

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]];

(* PolyPlot suppressed *)

PolyPlot1[Δ_]:=Module[{crs,m,maxc,minc,s,rect},
rect={{0,0},{1,0},{1,1},{0,1}};
If[Expand[Δ]===0,Graphics[],
m=Max[-Exponent[Δ,T,Min], Exponent[Δ,T,Max]];
crs=CoefficientRules[(T^m)Δ,{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]],
Tooltip[Polygon[({x+m-1/2,0}+#)&/@rect],c (T^(x-m))]
},AspectRatio->Min[1/5 ,1/(Sqrt[m+1])],ImagePadding->None,PlotRangePadding->None]
]];
Options[PolyPlot2]={Labeled->False};
PolyPlot2[θ_,OptionsPattern[]]:=Module[{crs,m1,m2,maxc,minc,s,hex,p},
If[Expand[θ]===0,Graphics[{White,Disk[]}],
hex=Table[{Cos[α],Sin[α]}/Cos[2π/12]/2, {α,2π/12,2π,2π/6}];
m1=Max[-Exponent[θ,(Subscript[T, 1]),Min], Exponent[θ,(Subscript[T, 1]),Max]];
m2=Max[-Exponent[θ,(Subscript[T, 2]),Min], Exponent[θ,(Subscript[T, 2]),Max]];
crs=CoefficientRules[(Subscript[T, 1]^m1)(Subscript[T, 2]^m2)θ,{(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[{(*{Yellow,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]],
p=(({{1, -1/2}, {0, (Sqrt[3])/2}})).{x1-m1,x2-m2};
Tooltip[Polygon[(p+#)&/@hex],c (Subscript[T, 1]^(x1-m1))(Subscript[T, 2]^(x2-m2))] ,
If[Not@OptionValue[Labeled],{},{Black, Text[Style[c (Subscript[T, 1]^(x1-m1))(Subscript[T, 2]^(x2-m2)),30],p]}]
}
},ImagePadding->None,PlotRangePadding->None]
]];
PolyPlot[{Δ_,θ_},opts___Rule]:=GraphicsColumn[
{PolyPlot1[Δ],PolyPlot2[θ,FilterRules[{opts},Options[PolyPlot2]]]},
Spacings -> Scaled@0.08,ImagePadding->None,PlotRangePadding->None,
FilterRules[{opts},Options[GraphicsColumn]]
];

PD[GST48]=PD[X[1,15,2,14],X[29,2,30,3],X[40,4,41,3],X[4,44,5,43],X[5,26,6,27],X[95,7,96,6],X[7,1,8,96],X[8,14,9,13],X[28,9,29,10],X[41,11,42,10],X[11,43,12,42],X[12,27,13,28],X[15,31,16,30],X[61,16,62,17],X[72,17,73,18],X[83,18,84,19],X[34,20,35,19],X[20,89,21,90],X[92,21,93,22],X[22,79,23,80],X[23,68,24,69],X[24,57,25,58],X[56,25,57,26],X[31,63,32,62],X[32,74,33,73],X[33,85,34,84],X[35,50,36,51],X[81,37,82,36],X[70,38,71,37],X[59,39,60,38],X[54,39,55,40],X[55,45,56,44],X[45,59,46,58],X[46,70,47,69],X[47,81,48,80],X[91,49,92,48],X[49,91,50,90],X[82,52,83,51],X[71,53,72,52],X[60,54,61,53],X[74,63,75,64],X[85,64,86,65],X[65,76,66,77],X[66,87,67,88],X[94,67,95,68],X[86,75,87,76],X[77,88,78,89],X[93,78,94,79]];

DunfieldKnots=ReadList["../../People/Dunfield/nmd_random_knots"]/.k_Integer:>k+1;
DK[n_]:=DunfieldKnots[[n-2]];

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

A “no g” version

Simplify[(((Subscript[T, 2])-1)/((Subscript[T, 2]^(-1))-1))]

(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);
CF[ℰ_] := Module[{vs=Union@Cases[ℰ,(Subscript[g, __]),∞],ps,c},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> Factor[c](Times@@(vs^ps))] ];
(Subscript[R, 11])[{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[R, 12])[{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_]=CF[-φ/2+φ (Subscript[g, 3,k,k])];

CF[Δ1 Δ2 Δ3((Subscript[T, 2])-1) (Subscript[R, 12])[{s0,i0,j0},{s1,i1,j1}]/.(Subscript[g, ν_,α_,β_]):>((Subscript[g, ν,α,β])/(ToExpression["Δ"<>ToString[ν]]))]/. s1(((Subscript[T, 2])-1)/((Subscript[T, 2]^s1)-1))->(Subscript[T, 2]^((1-s1)/2))/.(Subscript[g, ν_,α_,β_]):>G[[ν,α,β]]

CF[Δ1 Δ2 Δ3((Subscript[T, 2])-1) (Subscript[R, 11])[{s,i,j}]/.(Subscript[g, ν_,α_,β_]):>((Subscript[g, ν,α,β])/(ToExpression["Δ"<>ToString[ν]]))]/. s(((Subscript[T, 2])-1)/((Subscript[T, 2]^s)-1))->(Subscript[T, 2]^((1-s)/2))/.(Subscript[g, ν_,α_,β_]):>G[[ν,α,β]]

(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);
Θ[K_]:=Module[{Cs,φ,n,A,Δ,Δ1,Δ2,Δ3,G,s0,i0,j0,s1,i1,j1,s,i,j,θ=0,t=AbsoluteTime[]},
{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}})))];
Δ=Expand@Together[(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]];
{Δ1,Δ2,Δ3}=Table[Δ/.T->(Subscript[T, ν]),{ν,3}];
G=Expand@Cancel[Δ Inverse[A]];
Print["Done with G at ",AbsoluteTime[]-t];
G=Table[G/.T->(Subscript[T, ν]),{ν,3}];
Print["Done with commons at ",AbsoluteTime[]-t];
Do[{s0,i0,j0}=Cs[[k1]];{s1,i1,j1}=Cs[[k2]];
θ+=Expand[
G[[1,j1,i0]] G[[2,i1,i0]] G[[3,j0,i1]] (-1+(Subscript[T, 1]^s0)) (Subscript[T, 2]^(s0+((1-s1)/2))) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s1))-G[[1,j1,i0]] G[[2,j1,i0]] G[[3,j0,i1]] (-1+(Subscript[T, 1]^s0)) (Subscript[T, 2]^(s0+((1-s1)/2))) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s1))-G[[1,j1,i0]] G[[2,i1,j0]] G[[3,j0,i1]] (-1+(Subscript[T, 1]^s0)) (Subscript[T, 2]^((1-s1)/2)) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s1))+G[[1,j1,i0]] G[[2,j1,j0]] G[[3,j0,i1]] (-1+(Subscript[T, 1]^s0)) (Subscript[T, 2]^((1-s1)/2)) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s1))
],{k1,n},{k2,n}];
Echo@θ;
θ+=Sum[{s,i,j}=Cs[[k]];Expand[
(1/2) s Δ1 Δ2 Δ3 (-1+(Subscript[T, 2]))-s Δ3 G[[1,i,i]] G[[2,j,j]] (-1+(Subscript[T, 2]))-s Δ1 Δ2 G[[3,i,i]] (-1+(Subscript[T, 2]))+2 s Δ1 G[[2,j,j]] G[[3,i,i]] (-1+(Subscript[T, 2]))+s Δ2 G[[1,i,i]] G[[3,j,j]] (-1+(Subscript[T, 2]))-s Δ1 G[[2,i,i]] G[[3,j,j]] (-1+(Subscript[T, 2]))+s Δ3 G[[1,i,i]] G[[2,j,i]] (-1+(Subscript[T, 2])) (Subscript[T, 2]^s)-s Δ1 G[[2,j,i]] G[[3,j,j]] (-1+(Subscript[T, 2])) (Subscript[T, 2]^s)-Δ3 G[[1,j,i]] G[[2,j,j]] (-1+(Subscript[T, 1]^s)) (Subscript[T, 2]^(((1-s)/2)+s))+Δ2 G[[1,j,i]] G[[3,j,j]] (-1+(Subscript[T, 1]^s)) (Subscript[T, 2]^(((1-s)/2)+s))+Δ3 G[[1,j,i]] G[[2,j,i]] (-1+(Subscript[T, 1]^s)) (Subscript[T, 2]^(((1-s)/2)+2 s))-s Δ1 G[[2,j,i]] G[[3,i,i]] (-1+(Subscript[T, 2])) (-1+(Subscript[T, 2]^s))+s Δ1 G[[2,j,i]] G[[3,j,i]] (-1+(Subscript[T, 2])) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s))+Δ1 Δ2 G[[3,j,i]] (Subscript[T, 2]^((1-s)/2)) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s))+Δ1 G[[2,i,j]] G[[3,j,i]] (Subscript[T, 2]^((1-s)/2)) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s))-Δ2 G[[1,i,i]] G[[3,j,i]] (Subscript[T, 2]^(((1-s)/2)+s)) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s))+Δ1 G[[2,j,j]] G[[3,j,i]] (Subscript[T, 2]^((1-s)/2)) (-2+(Subscript[T, 2]^s)) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s))-Δ2 G[[1,j,i]] G[[3,j,i]] (-1+(Subscript[T, 1]^s)) (Subscript[T, 2]^((1-s)/2)) (1+(Subscript[T, 2]^s)) (-1+((((Subscript[T, 1]) (Subscript[T, 2])))^s))
],{k,n}];
Echo@θ;
θ+=Sum[Expand[φ[[k]] Δ1 Δ2((Subscript[T, 2])-1)( G[[3,k,k]]-Δ3/2)],{k,2n}];
Echo@θ;
Print["Done with θ at ",AbsoluteTime[]-t];
Factor@{Δ,θ/((Subscript[T, 2])-1)}
];

AbsoluteTiming@Short[th=Θ[Knot[3,1]]]
PolyPlot[th]

AbsoluteTiming@Short[th=Θ[GST48]]
PolyPlot[th]