Pensieve header: Computing and playing with $\rho_1$ in the language of perturbed Gaussian Integration.

Programs

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\APAI"];
Once[<<KnotTheory`; <<Rot.m];

CCF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[ℰ];
CF[ℰ_List]:=CF/@ℰ; CF[ℰ_EPD]:=CF/@ℰ;
CF[ℰ_] := Module[{vs=Cases[ℰ,(Subscript[(x|p), _]),∞]⋃{x,p},ps,c},
Total[CoefficientRules[Expand[ℰ], vs] /. (ps_->c_) :> CCF[c](Times@@(vs^ps))] ];
CF[eqp_EQP]:=CF/@eqp

EQP/:c_*EQP[Q_,P_]:=EQP[Q,CF[c P]];

{(SuperStar[p]),(SuperStar[x])}={π,ξ};  (SuperStar[((Subscript[z_, i__]))]):=(Subscript[((SuperStar[z])), i]); (SuperStar[vs_List]):=(v|->(SuperStar[v]))/@vs;
(Subscript[Zip, {}])[ℰ_]:=ℰ;
(Subscript[Zip, {z_,zs___}])[ℰ_] := (Collect[ℰ//(Subscript[Zip, {zs}]),z] /. f_.(z^(d_.)):>(D[f,{(SuperStar[z]),d}]))/.(SuperStar[z])->0

FI[EQP[Q_,P_]]:=FI[EQP[Q,P],Union@Cases[Q,(Subscript[p, _]),∞],Union@Cases[Q,(Subscript[x, _]),∞]];
FI[EQP[Q_,P_],ps_List,xs_List]:=Module[{u,v},
A=Table[(∂_(u,v))Q,{u,ps},{v,xs}];
Factor[((Det[A])^(-1))(Subscript[Zip, ps⋃xs])[P (E^(-(SuperStar[xs]).Inverse[A].(SuperStar[ps])))]]]

(Subscript[ρ, 0]) Tests

ρ0i[K_]:=ρ0i[K,False]; ρ0i[Flip@K_]:=ρ0i[K,True];
ρ0i[K_,flip_]:=Module[{Cs,φ,n,s,i,j,k,vs,Q,Qp},
{Cs,φ}=Rot[K]; n=Length[Cs];
If[flip, Cs=Cs[[All,{1,3,2}]]; φ=-φ];
Q=-(Subscript[p, 2n+1])(Subscript[x, 2n+1]); Qp=0;
Cases[Cs,{s_,i_,j_}:>(Q-=(Subscript[x, i]) ((Subscript[p, i])-(T^s) (Subscript[p, i+1])+((T^s)-1) (Subscript[p, j+1]))+(Subscript[x, j]) ((Subscript[p, j])-(Subscript[p, j+1])); Qp-=s (T^(s-1))(Subscript[x, i])((Subscript[p, j+1])-(Subscript[p, i+1])))];
EQP[Q,-(T^((Total[φ]+Total[Cs[[All,1]]])/2))Qp-(Total[φ]+Total[Cs[[All,1]]])(T^((Total[φ]+Total[Cs[[All,1]]])/2-1))/2]
];

K=Knot[8,17];
Factor[(∂_T)(((Alexander[K][T])^(-1)))]

K=Knot[3,1]; {Cs,φ}=Rot[K]; n=Length[Cs];ν={lν=0};writhe=Total@Cs[[All,1]];
Do[Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}, {k,2n}];
eqp=ρ0i[K];
eqp1=(T^(-writhe))CF[eqp/.Flatten@{{(Subscript[x, 2n+1])->(Subscript[p, 1]),(Subscript[p, 2n+1])->(Subscript[x, 2n+1])},Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(T^(ν[[i]]))(Subscript[p, j+1])+(1-(T^s)) (T^(ν[[i]]))(Subscript[p, i+1])+(T^(s+ν[[i]]))(Subscript[p, 1]),(Subscript[x, i])->-(T^(ν[[i]]))(Subscript[p, i+1])+(T^(ν[[i]]))(Subscript[p, 1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[i]]-s))(Subscript[x, j])}}];
eqp2=CF[ρ0i[Flip@K]/.T->(T^(-1))];
FI/@{eqp,eqp1,eqp2}

CF[eqp1[[1]]-eqp2[[1]]]

CF[(T^2)eqp1[[2]]+eqp2[[2]]]

FI@EQP[eqp1[[1]],(T^2)eqp1[[2]]+eqp2[[2]]]

(Subscript[ρ, 1]) Tests

(Subscript[r, 1])[s_,i_,j_]:=s (-1+2 (Subscript[p, i]) (Subscript[x, i])-2 (Subscript[p, j]) (Subscript[x, i])+(-1+(T^s)) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]^2)+(1-(T^s)) (Subscript[p, j]^2) (Subscript[x, i]^2)-2 (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])+2 (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j]))/2;
(Subscript[γ, 1])[φ_,k_]:=φ (1/2-(Subscript[p, k])(Subscript[x, k]));
ρ1i[K_]:=ρ1i[K,False]; ρ1i[Flip@K_]:=ρ1i[K,True];
ρ1i[K_,flip_]:=Module[{Cs,φ,n,s,i,j,k,vs,Q,P},
{Cs,φ}=Rot[K]; n=Length[Cs];
If[flip, Cs=Cs[[All,{1,3,2}]]; φ=-φ];
Q=-(Subscript[x, 2n+1])(Subscript[p, 2n+1]);
Cases[Cs,{s_,i_,j_}:>(Q-=(Subscript[x, i]) ((Subscript[p, i])-(T^s) (Subscript[p, i+1])+((T^s)-1) (Subscript[p, j+1]))+(Subscript[x, j]) ((Subscript[p, j])-(Subscript[p, j+1])))];
P=Sum[(Subscript[r, 1])@@Cs[[k]],{k,n}]+Sum[(Subscript[γ, 1])[φ[[k]],k],{k,2n}];
CF@EQP[Q,(T^((Total[φ]+Total[Cs[[All,1]]])/2))P]
];

K=Knot[5,2];
ρ1i[K]

Factor@Together[FI@ρ1i[K]]

K=Knot[3,1]; {Cs,φ}=Rot[K]; n=Length[Cs];ν={lν=0}; writhe=Total@Cs[[All,1]];
Do[Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}, {k,2n}];
eqp=ρ1i[K];
eqp1=(T^(-writhe))CF[eqp/.Flatten@{{(Subscript[x, 2n+1])->(Subscript[p, 1]),(Subscript[p, 2n+1])->(Subscript[x, 2n+1])},Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(T^(ν[[i]]))(Subscript[p, j+1])+(1-(T^s)) (T^(ν[[i]]))(Subscript[p, i+1])+(T^(s+ν[[i]]))(Subscript[p, 1]),(Subscript[x, i])->-(T^(ν[[i]]))(Subscript[p, i+1])+(T^(ν[[i]]))(Subscript[p, 1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[i]]-s))(Subscript[x, j])}}];
eqp2=CF[ρ1i[Flip@K]/.T->(T^(-1))];
FI/@{eqp,eqp1,eqp2}

CF[eqp1[[1]]-eqp2[[1]]]

CF[eqp1[[2]]-eqp2[[2]]]

FI@EQP[eqp1[[1]],eqp1[[2]]-eqp2[[2]]]

Monitor[sum=0;Do[
{Cs,φ}=Rot[K]; n=Length[Cs];ν={lν=0}; writhe=Total@Cs[[All,1]];
Do[Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}, {k,2n}];
eqp1=(T^(-writhe))CF[ρ1i[K]/.Flatten@{{(Subscript[x, 2n+1])->(Subscript[p, 1]),(Subscript[p, 2n+1])->(Subscript[x, 2n+1])},Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(T^(ν[[i]]))(Subscript[p, j+1])+(1-(T^s)) (T^(ν[[i]]))(Subscript[p, i+1])+(T^(s+ν[[i]]))(Subscript[p, 1]),(Subscript[x, i])->-(T^(ν[[i]]))(Subscript[p, i+1])+(T^(ν[[i]]))(Subscript[p, 1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[i]]-s))(Subscript[x, j])}}];
eqp2=CF[ρ1i[Flip@K]/.T->(T^(-1))];
sum+=Simplify[eqp1[[1]]==eqp2[[1]]]∧FI@eqp1==FI@eqp2,
{K,AllKnots[{3,10}]}
],{K,sum}]; sum

Monitor[sum=0;Do[
{Cs,φ}=Rot[K]; n=Length[Cs];ν={lν=0}; writhe=Total@Cs[[All,1]];
Do[Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}, {k,2n}];
eqp1=(T^(-writhe))CF[ρ1i[K]/.Flatten@{{(Subscript[x, 2n+1])->(Subscript[p, 1]),(Subscript[p, 2n+1])->(Subscript[x, 2n+1])},Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(T^(ν[[i]]))(Subscript[p, j+1])+(1-(T^s)) (T^(ν[[i]]))(Subscript[p, i+1])+(T^(s+ν[[i]]))(Subscript[p, 1]),(Subscript[x, i])->-(T^(ν[[i]]))(Subscript[p, i+1])+(T^(ν[[i]]))(Subscript[p, 1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[i]]-s))(Subscript[x, j])}}];
eqp2=CF[ρ1i[Flip@K]/.T->(T^(-1))];
sum+=Simplify[eqp1[[1]]==eqp2[[1]]]∧FI@EQP[eqp1[[1]],eqp1[[2]]-eqp2[[2]]]==0,
{K,AllKnots[{3,10}]}
],{K,sum}]; sum

Palindromicity for (Subscript[ρ, 1])

CF[(T^(-s))(Subscript[r, 1])[s,i,j]]

CF@PowerExpand@Plus[(Subscript[r, 1])[s,i,j]/.{(Subscript[x, j])->-(T^(νi))(Subscript[p, j+1])+(1-(T^s)) (T^(νi))(Subscript[p, i+1])+(T^(s+νi))(Subscript[p, 1]),(Subscript[x, i])->-(T^(νi))(Subscript[p, i+1])+(T^(νi))(Subscript[p, 1]),(Subscript[p, i])-> (T^(-νi))(Subscript[x, i]),(Subscript[p, j])-> (T^(-νi-s))(Subscript[x, j])},
(Subscript[r, 1])[s,j,i]/.T->(T^(-1))
]

K=Knot[3,1]; {Cs,φ}=Rot[K]; n=Length[Cs];ν={lν=0}; writhe=Total@Cs[[All,1]];
Do[Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}, {k,2n}];
eqp=ρ1i[K];
eqp1=(T^(-writhe))CF[eqp/.Flatten@{{(Subscript[x, 2n+1])->(Subscript[p, 1]),(Subscript[p, 2n+1])->(Subscript[x, 2n+1])},Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(T^(ν[[i]]))(Subscript[p, j+1])+(1-(T^s)) (T^(ν[[i]]))(Subscript[p, i+1])+(T^(s+ν[[i]]))(Subscript[p, 1]),(Subscript[x, i])->-(T^(ν[[i]]))(Subscript[p, i+1])+(T^(ν[[i]]))(Subscript[p, 1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[i]]-s))(Subscript[x, j])}}];
eqp2=CF[ρ1i[Flip@K]/.T->(T^(-1))];
FI@EQP[eqp1[[1]],eqp1[[2]]-eqp2[[2]]]
CF@EQP[eqp1[[1]],eqp1[[2]]-eqp2[[2]]]
CF@Plus[Sum[{s,i,j}=Cs[[k]];
-s+s (Subscript[p, 1]) (Subscript[x, i])-s (Subscript[p, 1+i]) (Subscript[x, i])-s (T^(-s)) (Subscript[p, 1]) (Subscript[x, j])-s (Subscript[p, i]) (Subscript[x, j])+s (T^(-s)) (Subscript[p, 1+i]) (Subscript[x, j])+s (Subscript[p, j]) (Subscript[x, j])+(1/2) (T^(-s)) (-s-s (T^s)) (Subscript[p, 1]^2) (Subscript[x, i]) (Subscript[x, j])+s (Subscript[p, i]^2) (Subscript[x, i]) (Subscript[x, j])+s (Subscript[p, 1]) (Subscript[p, 1+i]) (Subscript[x, i]) (Subscript[x, j])+(1/2) (T^(-s)) (s-s (T^s)) (Subscript[p, 1+i]^2) (Subscript[x, i]) (Subscript[x, j])-s (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])+s (T^(-s)) (Subscript[p, 1]) (Subscript[p, 1+j]) (Subscript[x, i]) (Subscript[x, j])-s (T^(-s)) (Subscript[p, 1+i]) (Subscript[p, 1+j]) (Subscript[x, i]) (Subscript[x, j])+(1/2) (T^(-2 s)) (s+s (T^s)) (Subscript[p, 1]^2) (Subscript[x, j]^2)+(1/2) (T^(-s)) (-s+s (T^s)) (Subscript[p, i]^2) (Subscript[x, j]^2)-s (T^(-s)) (Subscript[p, 1]) (Subscript[p, 1+i]) (Subscript[x, j]^2)+(1/2) (T^(-2 s)) (-s+s (T^s)) (Subscript[p, 1+i]^2) (Subscript[x, j]^2)+(1/2) (T^(-s)) (s-s (T^s)) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, j]^2)-s (T^(-2 s)) (Subscript[p, 1]) (Subscript[p, 1+j]) (Subscript[x, j]^2)+s (T^(-2 s)) (Subscript[p, 1+i]) (Subscript[p, 1+j]) (Subscript[x, j]^2),
{k,n}],
Sum[(Subscript[γ, 1])[φ[[k]],k],{k,2n}]
]