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=Knot[5,2]; {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: (Jacobian is (T^(-writhe)))

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: (Jacobian is (-1)).

(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: (Jacobian is 1).

(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^ν): (Jacobian is 1).

(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”: (Jacobian is 1, and so the overall Jacobian is -(T^(-writhe))).

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 a single knot - all in one shot

K=Knot[5,2]; {Cs,ρ}=Rot[K];  n=Length[Cs];ν={lν=0};
Do[Cs/.{{s_,k,j_}:>AppendTo[ν,lν+=s],{s_,i_,k}:>AppendTo[ν,lν-=s]}, {k,2n}];
Echo@{Cs,ν};
Q0p=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])];
Echo[Q0p==Q0];
Q1p=Echo@CF[Q0p/.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])})];
Echo[Q1p==Q1];
Q2p=Echo@CF[Q0p/.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])})/.{p->x,x->p}];
Echo[Q2p==Q2];
Q3p=Echo@CF[Q0p/.Flatten@{{(Subscript[x, 2n+1])->(Subscript[p, 2n+1]),(Subscript[p, 2n+1])->(Subscript[x, 2n+1])},Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(Subscript[p, j])+((T^(-s))-1) (Subscript[p, i]),(Subscript[x, i])->-(T^(-s)) (Subscript[p, i]),(Subscript[p, i])->(Subscript[x, i]),(Subscript[p, j])->(Subscript[x, j])}}];
Print["Testing Q3p: ",Simplify[Q3p-Q2]];
Q4p=Echo@CF[Q0p/.Flatten@{{(Subscript[x, 2n+1])->(Subscript[p, 1]),(Subscript[p, 2n+1])->(Subscript[x, 2n+1])},Cs/.{s_Integer,i_,j_}:>{(Subscript[x, j])->-(Subscript[p, j+1])+((T^(-s))-1) (Subscript[p, i+1]),(Subscript[x, i])->-(T^(-s)) (Subscript[p, i+1]),(Subscript[p, i])->(Subscript[x, i]),(Subscript[p, j])->(Subscript[x, j])}}];
Print["Testing Q4p: ",Simplify[Q4p-Q3]];
Q5p=Echo@CF[Q0p/.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^(ν[[j+1]]))(Subscript[p, j+1])+((T^(-s))-1) (T^(ν[[i+1]]))(Subscript[p, i+1]),(Subscript[x, i])->-(T^(-s))  (T^(ν[[i+1]]))(Subscript[p, i+1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[j]]))(Subscript[x, j])}}];
Print["Testing Q5p: ",Simplify[Q5p-Q4]];     (* Q4=Echo@CF[Q3/.{(Subscript[p, i_]):>(T^(ν[[i]]))(Subscript[p, i]),(Subscript[x, i_]):>(T^(-ν[[i]]))(Subscript[x, i])}]*)
Q6p=Echo@CF[Q0p/.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]),(Subscript[x, i])->-(T^(ν[[i]]))(Subscript[p, i+1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[i]]-s))(Subscript[x, j])}}];
Print["Testing Q6p: ",Simplify[Q6p-Q4]];
Q7p=Echo@CF[Q0p/.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]),(Subscript[x, i])->-(T^(ν[[i]]))(Subscript[p, i+1]),(Subscript[p, i])-> (T^(-ν[[i]]))(Subscript[x, i]),(Subscript[p, j])-> (T^(-ν[[i]]-s))(Subscript[x, j])}}/.(Subscript[p, k_])/;k>1:>(Subscript[p, k])-(Subscript[p, 1])];
Print["Testing Q7p: ",Simplify[Q7p-Q5]];
Q8p=Echo@CF[Q0p/.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])}}];
Print["Testing Q8p: ",Simplify[Q8p-Q5]];

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π])==CF[Q/.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^s)(Subscript[p, 1])-(Subscript[p, j+1])+(1-(T^s)) (Subscript[p, i+1]),(Subscript[x, i])->(Subscript[p, 1])-(Subscript[p, i+1]),(Subscript[p, i])->(Subscript[x, i]),(Subscript[p, j])->(T^(-s))(Subscript[x, j])}}]

Total@Table[{Cs,ρ}=Rot[K];  n=Length[Cs];
Q=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])];
(OverBar[Qπ])=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π])==CF[Q/.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^s)(Subscript[p, 1])-(Subscript[p, j+1])+(1-(T^s)) (Subscript[p, i+1]),(Subscript[x, i])->(Subscript[p, 1])-(Subscript[p, i+1]),(Subscript[p, i])->(Subscript[x, i]),(Subscript[p, j])->(T^(-s))(Subscript[x, j])}}],
{K,AllKnots[{3,5}]}
]

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

lhs=P0/.{i->j,j->i,(T^s)->(T^(-s))}

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

Simplify[gPair[lhs-rhs,{1,i,j,i+1,j+1}]/.{(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])}]

{(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])}/.{i->j,j->i,(T^s)->(T^(-s)),(T^(-s))->(T^s)}

Simplify[gPair[lhs-rhs,{1,i,j,i+1,j+1}]//.{(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(T^(-s)) (Subscript[g, j+1,β])+(1-(T^(-s))) (Subscript[g, i+1,β]),(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(Subscript[g, i+1,β]),(Subscript[g, α_,j]):>(T^s) ((Subscript[g, α,j+1])-(Subscript[δ, α,j+1])),(Subscript[g, α_,i]):>(Subscript[g, α,i+1])-(1-(T^(-s))) (Subscript[g, α,j])-(Subscript[δ, α,i+1])}]

e1=Simplify[gPair[lhs-rhs,{i,j,i+1,j+1}]//.{(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(T^(-s)) (Subscript[g, j+1,β])+(1-(T^(-s))) (Subscript[g, i+1,β]),(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(Subscript[g, i+1,β]),(Subscript[g, α_,j]):>(T^s) ((Subscript[g, α,j+1])-(Subscript[δ, α,j+1])),(Subscript[g, α_,i]):>(Subscript[g, α,i+1])-(1-(T^(-s))) (Subscript[g, α,j])-(Subscript[δ, α,i+1])}]

c1=Simplify[s((Subscript[g, i,i]^2)+(Subscript[g, j,j]^2)-(Subscript[g, i+1,i+1]^2)-(Subscript[g, j+1,j+1]^2))//.{(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(T^(-s)) (Subscript[g, j+1,β])+(1-(T^(-s))) (Subscript[g, i+1,β]),(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(Subscript[g, i+1,β]),(Subscript[g, α_,j]):>(T^s) ((Subscript[g, α,j+1])-(Subscript[δ, α,j+1])),(Subscript[g, α_,i]):>(Subscript[g, α,i+1])-(1-(T^(-s))) (Subscript[g, α,j])-(Subscript[δ, α,i+1])}]

c2=Simplify[((Subscript[g, j,j]^2)-(Subscript[g, i+1,i+1]^2))//.{(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(T^(-s)) (Subscript[g, j+1,β])+(1-(T^(-s))) (Subscript[g, i+1,β]),(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(Subscript[g, i+1,β]),(Subscript[g, α_,j]):>(T^s) ((Subscript[g, α,j+1])-(Subscript[δ, α,j+1])),(Subscript[g, α_,i]):>(Subscript[g, α,i+1])-(1-(T^(-s))) (Subscript[g, α,j])-(Subscript[δ, α,i+1])}]

Simplify[e1-a1 c1-a2 c2]

Simplify[e1-c1/2]