Pensieve header: Verifying g1 identities for the Gaussian pairing technique.

Reminders from GWU-1612.

Implementing (Subscript[𝔤, 1])

ϵ /: (ϵ^(k_))/;k>1:=0;
PBWRule={e->1,l->2,f->3};
B[U@e,U@l]=-U@e; B[U@f,U@l]=U@f; B[U@e,U@f]=h U[]-2ϵ U@l;

$TD=3; ℏ /: (ℏ^(d_. ))/;d>$TD :=0;

x_⪯y_:=OrderedQ[{x,y}/.PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.PBWRule];
Simp[ℰ_]:= Collect[ℰ, _U, Expand];

(Subscript[U, i_])[ℰ_] := ℰ /. {h->(Subscript[h, i]),t->(Subscript[t, i]), u_U :> Replace[u, x_ :> (Subscript[x, i]),1]};
B[U[(Subscript[(x_), i_])],U[(Subscript[(y_), i_])]]:=B[U[(Subscript[x, i])],U[(Subscript[y, i])]]=(Subscript[U, i])[B[U@x,U@y]];
B[U[(Subscript[(x_), i_])],U[(Subscript[(y_), j_])]] /; i=!=j := 0;
B[x_,x_]=0;
B[U[y_],U[x_]]:=B[U[y],U[x]]=Simp[-B[U[x],U[y]]];
B[x_,y_] := x**y-y**x;

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
0**_=_**0=0;
x_**U[]:=x; U[]**x_:=x;
(a_*x_U)**(b_*y_U) := If[a b === 0, 0, Simp[a b (x**y)]];
(a_*x_U)**y_ := Simp[a(x**y)]; x_**(a_*y_U) := Simp[a(x**y)];
(x_Plus)**y_ := (#**y)& /@ x; x_**(y_Plus) := (x**#)& /@ y;

U[xx___,x_] ** U[y_,yy___] := If[x⪯y,U[xx,x,y,yy], U@xx**(U@y**U@x+B[U@x,U@y])**U@yy];

UU[l___,((x_)^(n_)),r___]:= UU[l,Sequence@@Table[x,{n}],r];
UU[l___,1,r___]:= UU[l,r];
UU[]=U[];
UU[l_,r___]:=U[l]**UU[r];

UProducts[{},0]={UU[]};
UProducts[{},n_Integer] /; n>0 = {};
UProducts[{x_,xs___}, n_Integer] := Sort@Flatten@Table[UU[(x^k)]**u, {k,0,n},{u,UProducts[{xs},n-k]}];
UProducts[xs_List, k_Integer, n_Integer] := UProducts[Flatten@Table[(Subscript[x, j]), {x,xs}, {j,k}], n];
UProducts[any__, {n_}] := Flatten@Table[UProducts[any,k], {k,0,n}];

(Subscript[r, i_,j_]):=Simp[ℏ ((Subscript[h, i])UU[(Subscript[l, j])]-ϵ UU[(Subscript[l, i]),(Subscript[l, j])]+ UU[(Subscript[e, i]),(Subscript[f, j])])]

UExp[u_]:=Module[{s,t,k},
s=t=U[]; k=0;
While[k<20∧0=!=(t=t**u), s+=t/(++k)!];
Simp[s]
];
(Subscript[R, i_,j_]):=UExp[(Subscript[r, i,j])];

𝕆[poly_, specs___] := Module[{vs,us,z},
vs=Join@@(First /@ {specs});
us=Join@@({specs} /. (l_->s_) :> (l/.(Subscript[x_, i_]):>(Subscript[x, s])));
Simp@Total[CoefficientRules[Normal@Series[poly, {ℏ,0,$TD}], vs] /. (p_->c_) :> c UU@@((us^p))]
]

Testing YBE

UExp[ℏ U@(Subscript[e, 1])]

(Subscript[R, 1,2])

$TD=2; Simp[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])-(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])]

$TD=3; Simp[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])-(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])]

$TD=4; Simp[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])-(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])]

(Subscript[𝔤, 0]) tests

$TD=6;𝕆[Exp[ℏ (Subscript[h, 1])(Subscript[l, 2])+(((E^(ℏ (Subscript[h, 1])))-1)/(Subscript[h, 1]))(Subscript[e, 1])(Subscript[f, 2])], {(Subscript[e, 1])}->1,{(Subscript[l, 2]),(Subscript[f, 2])}->2]==(Subscript[R, 1,2]) /. ϵ->0

$TD=3; 𝕆[(E^(ℏ δ (Subscript[e, 1])(Subscript[f, 1]))), {(Subscript[f, 1]),(Subscript[e, 1])}->1]/. ϵ->0

$TD=3; With[{ν=(((1+ℏ (Subscript[h, 1])δ))^(-1))}, 𝕆[ν (E^(ℏ ν δ (Subscript[e, 1])(Subscript[f, 1]))), {(Subscript[e, 1]),(Subscript[f, 1])}->1]]/. ϵ->0

$TD=6; With[{ν=(((1+ℏ (Subscript[h, 1])δ))^(-1))}, 𝕆[(E^(ℏ δ (Subscript[e, 1])(Subscript[f, 1]))), {(Subscript[f, 1]),(Subscript[e, 1])}->1]==𝕆[ν (E^(ℏ ν δ (Subscript[e, 1])(Subscript[f, 1]))), {(Subscript[e, 1]),(Subscript[f, 1])}->1]/. ϵ->0]

(Subscript[𝔤, 1]) tests

Λ[ν_]:=Expand[
(1/(2 (μ^4)))(-b (α^2) (β^2)+(u^2) (β^2) δ (2+b δ)+(w^2) δ (α+u δ) (α (2+b δ)+u δ (4+3 b δ))-4 b α β δ μ+4 c α β (μ^2)-2 b (δ^2) (μ^2)+4 c δ (μ^3)+2 u β (α β+2 δ μ (1+c μ))+2 w ((α^2) β+2 α δ (u β (2+b δ)+μ (1+c μ))+u (δ^2) (u β (3+2 b δ)+2 μ (2+b δ+c μ)))) /. {α|β->0,μ->(ν^(-1)),b->ℏ (Subscript[h, 1]),c->(Subscript[l, 1]),u->ℏ (Subscript[e, 1]),w->(Subscript[f, 1])}
]

$TD=6; With[
{ν=(((1+ℏ (Subscript[h, 1])δ))^(-1))},
Simp[ 𝕆[(E^(ℏ δ (Subscript[e, 1])(Subscript[f, 1]))), {(Subscript[f, 1]),(Subscript[e, 1])}->1]-𝕆[ν(1+ϵ ℏ Λ[ν]) (E^(ℏ ν δ (Subscript[e, 1])(Subscript[f, 1]))), {(Subscript[e, 1]),(Subscript[l, 1]),(Subscript[f, 1])}->1]]
]

Λ[ν] /. {ℏ->1, (Subscript[x_, 1]):>x}

TeXForm[Λ[ν] /. {ℏ->1, (Subscript[x_, 1]):>x}]

Computations for Gaussian Pairing

Simplify[(1/(2 (μ^3)))(-b (α^2) (β^2)+(u^2) (β^2) δ (2+b δ)+(w^2) δ (α+u δ) (α (2+b δ)+u δ (4+3 b δ))-4 b α β δ μ+4 c α β (μ^2)-2 b (δ^2) (μ^2)+4 c δ (μ^3)+2 u β (α β+2 δ μ (1+c μ))+2 w ((α^2) β+2 α δ (u β (2+b δ)+μ (1+c μ))+u (δ^2) (u β (3+2 b δ)+2 μ (2+b δ+c μ)))) /. {δ->0,μ->1}]

Simplify[(1/(2 (μ^4)))(-b (α^2) (β^2)+(u^2) (β^2) δ (2+b δ)+(w^2) δ (α+u δ) (α (2+b δ)+u δ (4+3 b δ))-4 b α β δ μ+4 c α β (μ^2)-2 b (δ^2) (μ^2)+4 c δ (μ^3)+2 u β (α β+2 δ μ (1+c μ))+2 w ((α^2) β+2 α δ (u β (2+b δ)+μ (1+c μ))+u (δ^2) (u β (3+2 b δ)+2 μ (2+b δ+c μ)))) /. {δ->0,μ->1,b->ℏ (Subscript[h, 1]),c->(Subscript[l, 1]),u->ℏ (Subscript[e, 1]),w->(Subscript[f, 1])}]

$TD=8; Simp[ 𝕆[(E^(ℏ (α (Subscript[f, 1])+β (Subscript[e, 1])))), {(Subscript[f, 1]),(Subscript[e, 1])}->1]-𝕆[(1-(1/2) α β ϵ (ℏ^2) (-2 β ℏ (Subscript[e, 1])-2 α ℏ (Subscript[f, 1])+α β (ℏ^2) (Subscript[h, 1])-4 (Subscript[l, 1]))) (E^(ℏ (-ℏ (Subscript[h, 1]) α β +α (Subscript[f, 1])+β (Subscript[e, 1])))), {(Subscript[e, 1]),(Subscript[l, 1]),(Subscript[f, 1])}->1]]

Simplify[(1/(2 (μ^4)))(-b (α^2) (β^2)+(u^2) (β^2) δ (2+b δ)+(w^2) δ (α+u δ) (α (2+b δ)+u δ (4+3 b δ))-4 b α β δ μ+4 c α β (μ^2)-2 b (δ^2) (μ^2)+4 c δ (μ^3)+2 u β (α β+2 δ μ (1+c μ))+2 w ((α^2) β+2 α δ (u β (2+b δ)+μ (1+c μ))+u (δ^2) (u β (3+2 b δ)+2 μ (2+b δ+c μ)))) /. {b->h,c->l,u->e,w->f}]

Simplify[(1/(2 (μ^4)))(-b (α^2) (β^2)+(u^2) (β^2) δ (2+b δ)+(w^2) δ (α+u δ) (α (2+b δ)+u δ (4+3 b δ))-4 b α β δ μ+4 c α β (μ^2)-2 b (δ^2) (μ^2)+4 c δ (μ^3)+2 u β (α β+2 δ μ (1+c μ))+2 w ((α^2) β+2 α δ (u β (2+b δ)+μ (1+c μ))+u (δ^2) (u β (3+2 b δ)+2 μ (2+b δ+c μ)))) /. {b->h,c->l,u->e,w->f,α->0,β->0}]