Pensieve header: Palindromicity by flipping and manipulating, in Gaussian integration language.

Initialization and Programs

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\APAI"];
Once[
<<KnotTheory`;
<< Rot.m
];
CF[ℰ_]:=Sum[Factor[(∂_((Subscript[x, i]),(Subscript[p, j])))ℰ](Subscript[x, i])(Subscript[p, j]),{i,0,2n+2},{j,0,2n+2}];

(Subscript[δ, i_,j_]):=If[i===j,1,0];
(Subscript[gRules, s_,i_,j_]):={(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(T^s)(Subscript[g, i+1,β])+(1-(T^s))(Subscript[g, j+1,β]),(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(Subscript[g, j+1,β]),
(Subscript[g, α_,i]):>(T^(-s))((Subscript[g, α,i+1])-(Subscript[δ, α,i+1])),(Subscript[g, α_,j]):>(Subscript[g, α,j+1])-(1-(T^s))(Subscript[g, α,i])-(Subscript[δ, α,j+1])}

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

gPair[ℰ_,w_]:=Collect[(Subscript[Zip, Join@@Table[{(Subscript[p, α]),(Subscript[(OverBar[p]), α]),(Subscript[x, α]),(Subscript[(OverBar[x]), α])},{α,w}]])[ℰ Exp[Sum[(Subscript[g, α,β])((Subscript[π, α])+(Subscript[(OverBar[π]), α]))((Subscript[ξ, β])+(Subscript[(OverBar[ξ]), β])),{α,w},{β,w}]-Sum[(Subscript[(OverBar[ξ]), α])(Subscript[π, α]),{α,w}]]],(Subscript[g, __]),Factor]

Playing with a single knot

Initialization

K=Mirror@Knot[3,1]; {Cs,ρ}=Rot[K];  n=Length[Cs];ν={lν=0};
Do[Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}, {k,2n}];{Cs,ν}

The quadratic of K:

Q0=Echo@CF[Total[Cs/.{s_Integer,i_,j_}:>(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]))]+(Subscript[x, 2n+1])(Subscript[p, 2n+1])];

Applying (Subscript[x, j])->-(Subscript[x, j])+((T^(-s))-1) (Subscript[x, i]),(Subscript[x, i])->-(T^(-s)) (Subscript[x, i]) and splitting off the edge terms:

Echo@CF[Q0/.Join@@(Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(Subscript[x, j])+((T^(-s))-1) (Subscript[x, i]),(Subscript[x, i])->-(T^(-s)) (Subscript[x, i])})]==(Q1=CF[Total[Cs/.{s_Integer,i_,j_}:>-(T^(-s)) (Subscript[p, i]) (Subscript[x, i])-(Subscript[p, j]) (Subscript[x, i])+(T^(-s)) (Subscript[p, j]) (Subscript[x, i])-(Subscript[p, j]) (Subscript[x, j])]+Sum[(Subscript[x, k])(Subscript[p, k+1]),{k,1,2n}]+(Subscript[x, 2n+1])(Subscript[p, 2n+1])])

Transposing, shifting from forward edges to backwards edges:

(Q1/.{p->x,x->p})==Echo@(Q2=CF[Total[Cs/.{s_Integer,i_,j_}:>-(T^(-s)) (Subscript[x, i]) (Subscript[p, i])-(Subscript[x, j]) (Subscript[p, i])+(T^(-s)) (Subscript[x, j]) (Subscript[p, i])-(Subscript[x, j]) (Subscript[p, j])]+Sum[(Subscript[p, k])(Subscript[x, k+1]),{k,1,2n}]+(Subscript[p, 2n+1])(Subscript[x, 2n+1])])==CF[Total[Cs/.{s_Integer,i_,j_}:>-(T^(-s)) (Subscript[x, i]) (Subscript[p, i])-(Subscript[x, j]) (Subscript[p, i])+(T^(-s)) (Subscript[x, j]) (Subscript[p, i])-(Subscript[x, j]) (Subscript[p, j])]+Sum[(Subscript[p, k-1])(Subscript[x, k]),{k,1,2n}]-(Subscript[p, 0])(Subscript[x, 1])+(Subscript[p, 2n])(Subscript[x, 2n+1])+(Subscript[p, 2n+1])(Subscript[x, 2n+1])]

Permuting the p variables and re-absorbing the edge terms into the crossings:

(Q2/.{(Subscript[p, 2n+1])->(Subscript[p, 1]),(Subscript[p, i_]):>(Subscript[p, i+1])})==Echo@(Q3=CF[Total[Cs/.{s_Integer,i_,j_}:>-(T^(-s)) (Subscript[x, i]) (Subscript[p, i+1])-(Subscript[x, j]) (Subscript[p, i+1])+(T^(-s)) (Subscript[x, j]) (Subscript[p, i+1])-(Subscript[x, j]) (Subscript[p, j+1])]+Sum[(Subscript[p, k])(Subscript[x, k]),{k,1,2n}]-(Subscript[p, 1])(Subscript[x, 1])+(Subscript[p, 2n+1])(Subscript[x, 2n+1])+(Subscript[p, 1])(Subscript[x, 2n+1])])==CF[Total[Cs/.{s_Integer,i_,j_}:>-(T^(-s)) (Subscript[x, i]) (Subscript[p, i+1])+((T^(-s))-1) (Subscript[x, j]) (Subscript[p, i+1])-(Subscript[x, j]) (Subscript[p, j+1])+(Subscript[p, i])(Subscript[x, i])+(Subscript[p, j])(Subscript[x, j])]-(Subscript[p, 1])(Subscript[x, 1])+(Subscript[p, 2n+1])(Subscript[x, 2n+1])+(Subscript[p, 1])(Subscript[x, 2n+1])]

Rescaling by (T^ν):

(Q4=Echo@CF[Q3/.{(Subscript[p, i_]):>(T^(ν[[i]]))(Subscript[p, i]),(Subscript[x, i_]):>(T^(-ν[[i]]))(Subscript[x, i])}])==CF[Total[Cs/.{s_Integer,i_,j_}:>-(Subscript[x, i]) (Subscript[p, i+1])+((T^(-s))-1) (Subscript[x, j]) (Subscript[p, i+1])-(T^(-s))(Subscript[x, j]) (Subscript[p, j+1])+(Subscript[p, i])(Subscript[x, i])+(Subscript[p, j])(Subscript[x, j])]-(Subscript[p, 1])(Subscript[x, 1])+(Subscript[p, 2n+1])(Subscript[x, 2n+1])+(Subscript[p, 1])(Subscript[x, 2n+1])]

Using “col-sum = 0”:

Simplify[Echo@CF[Q4/.(Subscript[p, k_])/;k>1:>(Subscript[p, k])-(Subscript[p, 1])]==(Q5=CF[Total[Cs/.{s_Integer,i_,j_}:>(Subscript[x, j])((Subscript[p, j])-(T^(-s))(Subscript[p, j+1])+((T^(-s))-1)(Subscript[p, i+1]))+(Subscript[x, i])((Subscript[p, i])-(Subscript[p, i+1]))]+(Subscript[p, 2n+1])(Subscript[x, 2n+1])])]

The conjugate quadratic of the flip of K:

(OverBar[Qπ])=Echo@CF[Total[Cs/.{s_Integer,j_,i_}:>(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]))]+(Subscript[x, 2n+1])(Subscript[p, 2n+1])];

(OverBar[Qπ])==Q5

Playing with (Subscript[g, kk])

P0=(Subscript[x, i])(Subscript[p, i])+(Subscript[x, i])(Subscript[p, j])

Applying (Subscript[x, j])->-(Subscript[x, j])+((T^(-s))-1) (Subscript[x, i]),(Subscript[x, i])->-(T^(-s)) (Subscript[x, i]):

P1=P0/.{(Subscript[x, j])->-(Subscript[x, j])+((T^(-s))-1) (Subscript[x, i]),(Subscript[x, i])->-(T^(-s)) (Subscript[x, i])}

Transposing:

P2=P1/.{p->x,x->p}

Permuting the p variables and re-absorbing the edge terms into the crossings:

P3=P2/.{(Subscript[p, 2n+1])->(Subscript[p, 1]),(Subscript[p, i_]):>(Subscript[p, i+1])}

Rescaling by (T^ν):

P4=P3/.{(Subscript[p, i_]):>(T^(Subscript[v, i]))(Subscript[p, i]),(Subscript[x, i_]):>(T^(-(Subscript[v, i])))(Subscript[x, i])}/.{(Subscript[v, i+1])->(Subscript[v, i])+s, (Subscript[v, j])->(Subscript[v, i])+s,(Subscript[v, j+1])->(Subscript[v, i])}

P5=P4/.(Subscript[p, k_]):>(Subscript[p, k])-(Subscript[p, 1])

The conjugate quadratic of the flip of K:

P0/.{i->j,j->i}

Playing with (Subscript[R, 1])

(Subscript[r, 1]) is taken from Talks/Oaxaca-2210/Rho.nb

P0=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

Applying (Subscript[x, j])->-(Subscript[x, j])+((T^(-s))-1) (Subscript[x, i]),(Subscript[x, i])->-(T^(-s)) (Subscript[x, i]):

P1=P0/.{(Subscript[x, j])->-(Subscript[x, j])+((T^(-s))-1) (Subscript[x, i]),(Subscript[x, i])->-(T^(-s)) (Subscript[x, i])}

Transposing:

P2=P1/.{p->x,x->p}

Permuting the p variables and re-absorbing the edge terms into the crossings:

P3=P2/.{(Subscript[p, 2n+1])->(Subscript[p, 1]),(Subscript[p, i_]):>(Subscript[p, i+1])}

Rescaling by (T^ν):

P4=P3/.{(Subscript[p, i_]):>(T^(Subscript[v, i]))(Subscript[p, i]),(Subscript[x, i_]):>(T^(-(Subscript[v, i])))(Subscript[x, i])}

P4=Simplify[P3/.{(Subscript[p, i_]):>(T^(Subscript[v, i]))(Subscript[p, i]),(Subscript[x, i_]):>(T^(-(Subscript[v, i])))(Subscript[x, i])}/.{(Subscript[v, i+1])->(Subscript[v, i])+s, (Subscript[v, j])->(Subscript[v, i])+s,(Subscript[v, j+1])->(Subscript[v, i])}]

P5=Simplify[P4/.(Subscript[p, k_]):>(Subscript[p, k])-(Subscript[p, 1])]

The conjugate perturbation of the flip of K:

P0/.{T->(T^(-1)),i->j,j->i}

Simplify@PowerExpand[P5-(P0/.{T->(T^(-1)),i->j,j->i})]

gPair[Simplify@PowerExpand[P5-(P0/.{T->(T^(-1)),i->j,j->i})],{i,j}]

Simplify[gPair[Simplify@PowerExpand[P5-(P0/.{T->(T^(-1)),i->j,j->i})]/.{p->x,x->p},{i,j}]//.(Subscript[gRules, s,i,j])]