Pensieve header: Playing games with magnitudes.

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

Once[
<< KnotTheory`;
<< "../../Talks/MonteVerita-2604/Rot.m";
<< "../../Talks/MonteVerita-2604/PolyPlot.m"
]

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

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

(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[g, 2,i,j])+((Subscript[T, 2]^s)-2)(Subscript[g, 2,j,j])-((Subscript[T, 1]^s)-1)((Subscript[T, 2]^s)+1) (Subscript[g, 1,j,i])))/((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_]=φ (Subscript[g, 3,k,k])-φ/2;

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

Expand[Θ[Knot[3,1]]]

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

θDK[n_]:=Get["../HigherRank/DunfieldKnots/D"<>DKString[n]<>".m"][[2]]

θDK[3]

Table[
sec=Coefficient[Expand@θDK[n][[2]],T2,0]/.T1->T;
me=Exponent[sec,T,Min];
ListPlot[Log[1+Abs@CoefficientList[sec/(T^me),T]]],
{n,10,300,10}
]

Table[
sec=Coefficient[Expand@Θ[TorusKnot[3n+1,3]][[2]],(Subscript[T, 2]),0]/.(Subscript[T, 1])->T;
me=Exponent[sec,T,Min];
ListPlot[Log[1+Abs@CoefficientList[sec/(T^me),T]]],
{n,1,10}
]

Table[
sec=Coefficient[Expand@Θ[TorusKnot[3n+2,3]][[2]],(Subscript[T, 2]),0]/.(Subscript[T, 1])->T;
me=Exponent[sec,T,Min];
ListPlot[Log[1+Abs@CoefficientList[sec/(T^me),T]]],
{n,1,10}
]

Table[
sec=Coefficient[Expand@Θ[TorusKnot[n,n-1]][[2]],(Subscript[T, 2]),0]/.(Subscript[T, 1])->T;
me=Exponent[sec,T,Min];
ListPlot[Log[1+Abs@CoefficientList[sec/(T^me),T]]],
{n,3,10}
]

Table[
sec=Coefficient[Expand@Θ[TorusKnot[n,n-1]][[2]],(Subscript[T, 2]),0]/.(Subscript[T, 1])->T;
me=Exponent[sec,T,Min];
ListPlot[Log[1+Abs@CoefficientList[sec/(T^me),T]]],
{n,3,12}
]