Pensieve header: Searching for perturbations of the Heisenberg R-matrix.

hp[i,j] is the positive Heisenberg R-matrix.

hp/: P_𝒫**hp[i_,j_]:=Simplify[P/.{(Subscript[x, i])->(Subscript[x, i])-(T-1)(Subscript[x, j]),(Subscript[x, j])->T (Subscript[x, j])}];
hp/: hp[i_,j_]**P_𝒫:=Simplify[P/.{(Subscript[p, j])->(Subscript[p, j])-(T-1)((Subscript[p, i])-(Subscript[p, j]))}]

𝒫[P[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]]**hp[1,2]

𝒫[P[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]]**hp[1,2]**hp[1,3]

𝒫[P[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]]**hp[1,2]**hp[1,3]**hp[2,3]

𝒫[P[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]]**hp[2,3]**hp[1,3]**hp[1,2]

hp[1,2]**hp[1,3]**hp[2,3]**𝒫[P[(Subscript[p, 1]),(Subscript[p, 2]),(Subscript[p, 3])]]

hp[2,3]**hp[1,3]**hp[1,2]**𝒫[P[(Subscript[p, 1]),(Subscript[p, 2]),(Subscript[p, 3])]]

(Subscript[F, i_,j_]):=𝒫[F[(Subscript[p, i]),(Subscript[x, i]),(Subscript[p, j]),(Subscript[x, j])]];
eq=(Subscript[F, 1,2])**hp[1,3]**hp[2,3]+hp[1,2]**(Subscript[F, 1,3])**hp[2,3]+hp[1,2]**hp[1,3]**(Subscript[F, 2,3])-(Subscript[F, 2,3])**hp[1,3]**hp[1,2]-hp[2,3]**(Subscript[F, 1,3])**hp[1,2]-hp[2,3]**hp[1,3]**(Subscript[F, 1,2])

Expand[eq/.𝒫[F[p1_,x1_,p2_,x2_]]:>(p1-p2)x2]

Expand[eq/.𝒫[F[p1_,x1_,p2_,x2_]]:>p1 x1-T p1 x2]

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}];

AllMonomials[{p1,p2,p3},{2}]

Basis[n_,m_]:=Flatten@Outer[Times,AllMonomials[Table[(Subscript[p, j]),{j,n}],m],AllMonomials[Table[(Subscript[x, j]),{j,n}],m]];
Basis[n_,{m_}]:=Flatten@Table[Basis[n,k],{k,1,m}]

{Basis[2,2],Basis[2,{2}]}

MatrixForm[mat=Table[
Coefficient[
eq/.𝒫[F[p1_,x1_,p2_,x2_]]:> Expand[in/.{(Subscript[p, 1])->p1,(Subscript[p, 2])->p2,(Subscript[x, 1])->x1,(Subscript[x, 2])->x2}],
out
] /. (Subscript[(p|x), _])->0,
{in,Basis[2,{2}]},{out,Basis[3,{2}]}
]]

Simplify[T NullSpace[Transpose@mat].Basis[2,{2}]]

MatrixForm[mat=Table[
Coefficient[
eq/.𝒫[F[p1_,x1_,p2_,x2_]]:> Expand[in/.{(Subscript[p, 1])->p1,(Subscript[p, 2])->p2,(Subscript[x, 1])->x1,(Subscript[x, 2])->x2}],
out
] /. (Subscript[(p|x), _])->0,
{in,Basis[2,{4}]},{out,Basis[3,{4}]}
]]

Factor[(T^3) NullSpace[Transpose@mat].Basis[2,{4}]]

Unprotect[SeriesData];
SeriesData/:Expand[sd_SeriesData] := MapAt[Expand,sd,3];
Protect[SeriesData];

(((Subscript[𝔼, n_])[Q_,P_])^(m_[l___]))^:=(Subscript[𝔼, m])[Q,P]/.Flatten@Table[{(Subscript[p, i])->(Subscript[p, {l}[[i]]]),(Subscript[x, i])->(Subscript[x, {l}[[i]]])},{i,n}]

Unprotect[NonCommutativeMultiply];
(Subscript[𝔼, n_])[Q1_,P1_]**(Subscript[𝔼, n_])[Q2_,P2_]:=Module[{i,k,pp,xx},
Expand/@(Subscript[𝔼, n])[
Q1+Q2+Sum[((∂_(Subscript[x, i]))Q1)((∂_(Subscript[p, i]))Q2), {i,n}],
Expand[(P1/.Table[(Subscript[x, i])->(Subscript[x, i])+(Subscript[xx, i])+(∂_(Subscript[p, i]))Q2,{i,n}])(P2/.Table[(Subscript[p, i])->(Subscript[p, i])+(Subscript[pp, i])+(∂_(Subscript[x, i]))Q1,{i,n}])]//.(Subscript[pp, i_]^(k_.))(Subscript[xx, i_]^(k_.))->k!/.(Subscript[(pp|xx), _])->0
]]

RandomPolynomial[specs___]:=Basis[specs].Table[RandomInteger[{-9,9}],Length@Basis[specs]];
Clear[RE];
RE[k_]:=RE[k]=(Subscript[𝔼, 2])[RandomPolynomial[2,1],1+ϵ RandomPolynomial[2,{2}]+(ϵ^2) RandomPolynomial[2,{4}]+((O[ϵ])^3)];
RE[1]

l=RE[1]**RE[2];
r=RE[2]**RE[3];
l**RE[3]==RE[1]**r

R=(Subscript[𝔼, 2])[(T-1)((Subscript[p, 1])-(Subscript[p, 2]))(Subscript[x, 2]),1+ϵ(1/2) (Subscript[p, 1]) (Subscript[x, 2]) (2 T (Subscript[p, 2]) (Subscript[x, 1])+(Subscript[p, 1]) ((1-3 T) (Subscript[x, 1])+(-1+T) T (Subscript[x, 2])))+((O[ϵ])^3)]/.(Subscript[p, i_]):>-(Subscript[p, i])

(R^(3[1,3]))

(R^(3[1,2]))**(R^(3[1,3]))**(R^(3[2,3]))

(R^(3[1,2]))**(R^(3[1,3]))**(R^(3[2,3]))==(R^(3[2,3]))**(R^(3[1,3]))**(R^(3[1,2]))

R=(Subscript[𝔼, 2])[(T-1)((Subscript[p, 1])-(Subscript[p, 2]))(Subscript[x, 2]),1+ϵ(Subscript[p, 1]) (Subscript[x, 2]) (-(Subscript[p, 1]) (Subscript[x, 1])+T (Subscript[p, 2]) (Subscript[x, 2]))+((O[ϵ])^3)]/.(Subscript[p, i_]):>-(Subscript[p, i])

R=(Subscript[𝔼, 2])[(T-1)((Subscript[p, 1])-(Subscript[p, 2]))(Subscript[x, 2]),1+ϵ(1/2) (Subscript[p, 1]) (Subscript[x, 2]) (2 T (Subscript[p, 2]) (Subscript[x, 1])+(Subscript[p, 1]) ((1-3 T) (Subscript[x, 1])+(-1+T) T (Subscript[x, 2])))+((O[ϵ])^3)]/.(Subscript[p, i_]):>-(Subscript[p, i]);
err=(ϵ^(-2))Normal[Last[(R^(3[1,2]))**(R^(3[1,3]))**(R^(3[2,3]))]-Last[(R^(3[2,3]))**(R^(3[1,3]))**(R^(3[1,2]))]]

v=Table[Coefficient[err,c]/. (Subscript[(p|x), _])->0,{c,Basis[3,{4}]}]

mat=Table[
R=(Subscript[𝔼, 2])[(T-1)((Subscript[p, 2])-(Subscript[p, 1]))(Subscript[x, 2]),1+ϵ(1/2) (Subscript[p, 1]) (Subscript[x, 2]) (2 T (Subscript[p, 2]) (Subscript[x, 1])+(Subscript[p, 1]) ((1-3 T) (Subscript[x, 1])+(-1+T) T (Subscript[x, 2])))+(ϵ^2)b+((O[ϵ])^3)];db=(ϵ^(-2))Normal[Last[(R^(3[1,2]))**(R^(3[1,3]))**(R^(3[2,3]))]-Last[(R^(3[2,3]))**(R^(3[1,3]))**(R^(3[1,2]))]];
Table[Coefficient[db,c]/. (Subscript[(p|x), _])->0,{c,Basis[3,{4}]}],
{b,Basis[2,{4}]}]

LinearSolve[(mat^\[Transpose]),v].Basis[2,{4}]

Module[{A,B1,B2},
A=(({{1, -1, 0}, {-1, 1, 0}, {0, 0, 0}})); B1=(({{0, 0, 0}, {0, 1, -1}, {0, -1, 1}})); B2=(({{1, 0, -1}, {0, 0, 0}, {-1, 0, 1}}));
MatrixForm/@{A.B1-B1.A, A.B2-B2.A}
]