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

FI[EQP[(Subscript[x, 1])(Subscript[p, 2]),ϵ (Subscript[p, 2]^7)(Subscript[x, 1]^7)]]

FI[EQP[(Subscript[x, 1])(Subscript[p, 2])+3(Subscript[x, 2])(Subscript[p, 1]),ϵ (Subscript[p, 2]^5)(Subscript[x, 1]^5)]]

FI[EQP[(Subscript[x, 1])(Subscript[p, 2])+(Subscript[x, 2])(Subscript[p, 3])+(Subscript[x, 3])(Subscript[p, 1]),ϵ (Subscript[x, 1]^5)(Subscript[p, 2]^5)]]

FI[EQP[(Subscript[x, 1])(Subscript[p, 2]),ϵ (Subscript[x, 2]^7)(Subscript[p, 1]^7)]]

FI@EQP[(-(Subscript[p, 1]) (Subscript[x, 1])+(Subscript[p, 2]) (Subscript[x, 1])-(Subscript[p, 2]) (Subscript[x, 2])+(((Subscript[p, 3]) (Subscript[x, 2]))/T)+(((-1+T) (Subscript[p, 8]) (Subscript[x, 2]))/T)-(Subscript[p, 3]) (Subscript[x, 3])+(Subscript[p, 4]) (Subscript[x, 3])+(((-1+T) (Subscript[p, 2]) (Subscript[x, 4]))/T)-(Subscript[p, 4]) (Subscript[x, 4])+(((Subscript[p, 5]) (Subscript[x, 4]))/T)-(Subscript[p, 5]) (Subscript[x, 5])+(Subscript[p, 6]) (Subscript[x, 5])-(Subscript[p, 6]) (Subscript[x, 6])+(((Subscript[p, 7]) (Subscript[x, 6]))/T)+(((-1+T) (Subscript[p, 10]) (Subscript[x, 6]))/T)-(Subscript[p, 7]) (Subscript[x, 7])+(Subscript[p, 8]) (Subscript[x, 7])+(((-1+T) (Subscript[p, 4]) (Subscript[x, 8]))/T)-(Subscript[p, 8]) (Subscript[x, 8])+(((Subscript[p, 9]) (Subscript[x, 8]))/T)-(Subscript[p, 9]) (Subscript[x, 9])+(Subscript[p, 10]) (Subscript[x, 9])+(((-1+T) (Subscript[p, 6]) (Subscript[x, 10]))/T)-(Subscript[p, 10]) (Subscript[x, 10])+(((Subscript[p, 11]) (Subscript[x, 10]))/T)-(Subscript[p, 11]) (Subscript[x, 11])),(2+(Subscript[p, 4]) (Subscript[x, 1])-(Subscript[p, 1]) (Subscript[p, 4]) (Subscript[x, 1]^2)-(((-1+T) (Subscript[p, 4]^2) (Subscript[x, 1]^2))/(2 T))-(Subscript[p, 2]) (Subscript[x, 2])+(Subscript[p, 8]) (Subscript[x, 3])-(Subscript[p, 3]) (Subscript[p, 8]) (Subscript[x, 3]^2)-(((-1+T) (Subscript[p, 8]^2) (Subscript[x, 3]^2))/(2 T))+(Subscript[p, 1]) (Subscript[p, 4]) (Subscript[x, 1]) (Subscript[x, 4])+(((-1+T) (Subscript[p, 4]^2) (Subscript[x, 1]) (Subscript[x, 4]))/(2 T))+(Subscript[p, 10]) (Subscript[x, 5])-(Subscript[p, 5]) (Subscript[p, 10]) (Subscript[x, 5]^2)-(((-1+T) (Subscript[p, 10]^2) (Subscript[x, 5]^2))/(2 T))-(Subscript[p, 6]) (Subscript[x, 6])+(Subscript[p, 2]) (Subscript[x, 7])+(((-1+T) (Subscript[p, 2]^2) (Subscript[x, 2]) (Subscript[x, 7]))/(2 T))+(Subscript[p, 2]) (Subscript[p, 7]) (Subscript[x, 2]) (Subscript[x, 7])-(((-1+T) (Subscript[p, 2]^2) (Subscript[x, 7]^2))/(2 T))-(Subscript[p, 2]) (Subscript[p, 7]) (Subscript[x, 7]^2)-(Subscript[p, 8]) (Subscript[x, 8])+(Subscript[p, 3]) (Subscript[p, 8]) (Subscript[x, 3]) (Subscript[x, 8])+(((-1+T) (Subscript[p, 8]^2) (Subscript[x, 3]) (Subscript[x, 8]))/(2 T))+(Subscript[p, 6]) (Subscript[x, 9])-(Subscript[p, 9]) (Subscript[x, 9])+(((-1+T) (Subscript[p, 6]^2) (Subscript[x, 6]) (Subscript[x, 9]))/(2 T))+(Subscript[p, 6]) (Subscript[p, 9]) (Subscript[x, 6]) (Subscript[x, 9])-(((-1+T) (Subscript[p, 6]^2) (Subscript[x, 9]^2))/(2 T))-(Subscript[p, 6]) (Subscript[p, 9]) (Subscript[x, 9]^2)+(Subscript[p, 5]) (Subscript[p, 10]) (Subscript[x, 5]) (Subscript[x, 10])+(((-1+T) (Subscript[p, 10]^2) (Subscript[x, 5]) (Subscript[x, 10]))/(2 T))) ]

(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,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=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=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,7}]}
],{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=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,7}]}
],{K,sum}]; sum

Palindromicity for (Subscript[ρ, 1])

CF[-((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, 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])}]

Q=CF@PowerExpand[-((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])))/.{i->j,j->i,T->(T^(-1))}]

Clear[s,i,j];CF[(s^(-1))(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))
]/s]

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=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]]]
diff=CF@Plus[Sum[
s ((Subscript[p, 1]) (Subscript[x, i])-(Subscript[p, 1+i]) (Subscript[x, i])-(T^(-s)) (Subscript[p, 1]) (Subscript[x, j])+(Subscript[p, i]) (Subscript[x, j])+(T^(-s)) (Subscript[p, 1+i]) (Subscript[x, j])-(Subscript[p, j]) (Subscript[x, j])+(1/2) (T^(-s)) (-1-(T^s)) (Subscript[p, 1]^2) (Subscript[x, i]) (Subscript[x, j])-(Subscript[p, i]^2) (Subscript[x, i]) (Subscript[x, j])+(Subscript[p, 1]) (Subscript[p, 1+i]) (Subscript[x, i]) (Subscript[x, j])+(1/2) (T^(-s)) (1-(T^s)) (Subscript[p, 1+i]^2) (Subscript[x, i]) (Subscript[x, j])+(Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])+(T^(-s)) (Subscript[p, 1]) (Subscript[p, 1+j]) (Subscript[x, i]) (Subscript[x, j])-(T^(-s)) (Subscript[p, 1+i]) (Subscript[p, 1+j]) (Subscript[x, i]) (Subscript[x, j])+(1/2) (T^(-2 s)) (1+(T^s)) (Subscript[p, 1]^2) (Subscript[x, j]^2)+(1/2) (T^(-s)) (1-(T^s)) (Subscript[p, i]^2) (Subscript[x, j]^2)-(T^(-s)) (Subscript[p, 1]) (Subscript[p, 1+i]) (Subscript[x, j]^2)+(1/2) (T^(-2 s)) (-1+(T^s)) (Subscript[p, 1+i]^2) (Subscript[x, j]^2)+(1/2) (T^(-s)) (-1+(T^s)) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, j]^2)-(T^(-2 s)) (Subscript[p, 1]) (Subscript[p, 1+j]) (Subscript[x, j]^2)+(T^(-2 s)) (Subscript[p, 1+i]) (Subscript[p, 1+j]) (Subscript[x, j]^2))
/.Thread[{s,i,j}->Cs[[k]]],
{k,n}],
0Sum[(Subscript[γ, 1])[φ[[k]],k],{k,2n}]
]
CF[eqp1[[2]]-eqp2[[2]]-diff/.(Subscript[(p|x), 1])->0]

Q

Cs

f0=(Subscript[x, i])(Subscript[x, i])(Subscript[p, j]); f1=CF[(∂_(Subscript[x, i]))f0+f0(∂_(Subscript[x, i]))Q]
Table[FI[EQP[-(Subscript[p, 1]) (Subscript[x, 1])+T (Subscript[p, 2]) (Subscript[x, 1])+(1-T) (Subscript[p, 5]) (Subscript[x, 1])-(Subscript[p, 2]) (Subscript[x, 2])+(Subscript[p, 3]) (Subscript[x, 2])-(Subscript[p, 3]) (Subscript[x, 3])+T (Subscript[p, 4]) (Subscript[x, 3])+(1-T) (Subscript[p, 7]) (Subscript[x, 3])-(Subscript[p, 4]) (Subscript[x, 4])+(Subscript[p, 5]) (Subscript[x, 4])+(1-T) (Subscript[p, 3]) (Subscript[x, 5])-(Subscript[p, 5]) (Subscript[x, 5])+T (Subscript[p, 6]) (Subscript[x, 5])-(Subscript[p, 6]) (Subscript[x, 6])+(Subscript[p, 7]) (Subscript[x, 6])-(Subscript[p, 7]) (Subscript[x, 7]),f1]],{i,7},{j,7}]//MatrixForm

List@@Expand[((((Subscript[x, i])+(Subscript[x, j])+(Subscript[x, i+1])+(Subscript[x, j+1])))^2)]

ders=Flatten@Table[{v,f0,f1}->CF[f1 (∂_v)f0+f1 f0(∂_v)Q],{v,{(Subscript[x, i]),(Subscript[x, j])}},{f0,List@@Expand[((((Subscript[x, i])+(Subscript[x, j])))^2)]},{f1,{(Subscript[p, i]),(Subscript[p, j])}}]

Table[Simplify@FI[EQP[-(Subscript[p, 1]) (Subscript[x, 1])+T (Subscript[p, 2]) (Subscript[x, 1])+(1-T) (Subscript[p, 5]) (Subscript[x, 1])-(Subscript[p, 2]) (Subscript[x, 2])+(Subscript[p, 3]) (Subscript[x, 2])-(Subscript[p, 3]) (Subscript[x, 3])+T (Subscript[p, 4]) (Subscript[x, 3])+(1-T) (Subscript[p, 7]) (Subscript[x, 3])-(Subscript[p, 4]) (Subscript[x, 4])+(Subscript[p, 5]) (Subscript[x, 4])+(1-T) (Subscript[p, 3]) (Subscript[x, 5])-(Subscript[p, 5]) (Subscript[x, 5])+T (Subscript[p, 6]) (Subscript[x, 5])-(Subscript[p, 6]) (Subscript[x, 6])+(Subscript[p, 7]) (Subscript[x, 6])-(Subscript[p, 7]) (Subscript[x, 7]),d/.{s->-1,i->2,j->5}]], {d,Last/@ders}]

Last/@ders

Module[{i,j,k},
AllMonomials[{},0]={1};
AllMonomials[{},d_Integer] /; d>0 := {};
AllMonomials[{v_,vs___},d_Integer] := Join@@Table[(v^(d-k))AllMonomials[{vs},k],{k,0,d}];
AllMonomials[vs_List, {d_}] := Join@@Table[AllMonomials[vs,k],{k,0,d}];
Basis[js_List,m_]:=Flatten@Outer[Times,AllMonomials[Table[(Subscript[p, j]),{j,js}],m],AllMonomials[Table[(Subscript[x, j]),{j,js}],m]];
Basis[js_List,{m_}]:=Flatten@Table[Basis[js,k],{k,0,m}];
GenericCombination[bas_,c_]:=bas.Table[(Subscript[c, j]),{j,Length@bas}];
GenericCombination[bas_,(Subscript[c_, k_])]:=bas.Table[(Subscript[c, k,j]),{j,Length@bas}];
]

Basis[{i,j},2]

Table[Coefficient[r,b],{r,Last/@ders},{b,Basis[{i,j,i+1,j+1},2]}]//MatrixForm

vans=CF/@(
RowReduce[
Table[
Coefficient[r,b]/.(Subscript[(p|x), _])->0,
{r,(Last/@ders)⋃{(Subscript[x, i+1])(Subscript[p, i+1])+(Subscript[x, j+1])(Subscript[p, j+1])-(Subscript[x, i])(Subscript[p, i])-(Subscript[x, j])(Subscript[p, j]),(Subscript[x, i+1]^2)(Subscript[p, i+1]^2)+(Subscript[x, j+1]^2)(Subscript[p, j+1]^2)-(Subscript[x, i]^2)(Subscript[p, i]^2)-(Subscript[x, j]^2)(Subscript[p, j]^2)}},
{b,bas=Basis[{i,j,i+1,j+1},2]⋃Basis[{i,j,i+1,j+1},1]}
]
].bas
)

Table[Simplify@FI[EQP[-(Subscript[p, 1]) (Subscript[x, 1])+T (Subscript[p, 2]) (Subscript[x, 1])+(1-T) (Subscript[p, 5]) (Subscript[x, 1])-(Subscript[p, 2]) (Subscript[x, 2])+(Subscript[p, 3]) (Subscript[x, 2])-(Subscript[p, 3]) (Subscript[x, 3])+T (Subscript[p, 4]) (Subscript[x, 3])+(1-T) (Subscript[p, 7]) (Subscript[x, 3])-(Subscript[p, 4]) (Subscript[x, 4])+(Subscript[p, 5]) (Subscript[x, 4])+(1-T) (Subscript[p, 3]) (Subscript[x, 5])-(Subscript[p, 5]) (Subscript[x, 5])+T (Subscript[p, 6]) (Subscript[x, 5])-(Subscript[p, 6]) (Subscript[x, 6])+(Subscript[p, 7]) (Subscript[x, 6])-(Subscript[p, 7]) (Subscript[x, 7]),d/.{s->-1,i->2,j->5}]], {d,vans}]