Pensieve header: Working in the double of the 2D pencil, as determined in “Doubling.nb”.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2017-06"];

The “degree carrier” is ℏ, and all “coupling constants” are proportional to it.

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

The Doubled Algebra (Subscript[𝒰, ℏαβ])

Change relative to “Doubling.nb”: We use t=βa-αb and T=(e^(ℏt))=(A^(-1))B instead of b and B.

Implementing (Subscript[𝒰, ℏαβ])

With q=(e^(ℏαβ)), A=(e^(-ℏβa)), and (Subscript[[f,g], q]):=fg-qgf, our algebra is (Subscript[𝒰, ℏαβ])=⟨t,y,a,x⟩/ℛ, where ℛ=([t,*]=0, [a,y]=-αy, (Subscript[[x,y], q])=(ℏ^(-1))(1-(TA^2)),[x,a]=-αx).

Series[(h^(-1))(1-(E^(h t-2h β a))), {h,0,5}]

q:=Sum[((((ℏ α β))^k)/(k!)), {k,0,$TD}];
AlgebraAtom = y|a|x;
PBWRule={y->1,a->2,x->3};
B[U@a,U@y]=-α U@y; B[U@x,U@a]=-α U@x;
B[U@x,U@y]=(q-1)UU[y,x]+UU@Sum[-(((((t-2 a β))^(k+1))(ℏ^k))/((k+1)!)) ,{k,0,$TD}];

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

(Subscript[U, 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[c_.*((l_)^(n_)),r___]/;FreeQ[c, AlgebraAtom]:= Expand[c UU[Sequence@@Table[l,{n}],r]];
UU[c_.*l:AlgebraAtom,r___] := Expand[c U[l]**UU[r]];
UU[c_,r___]/;FreeQ[c, AlgebraAtom]:= Expand[c UU[r]];
UU[]=U[];
UU[l_Plus, r___] := UU[#,r]& /@ l;
UU[l_,r___] := UU[Expand[l],r];

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

B[U@x,U@y]//Simp

$TD=2; z1=U[y,y,a,a,x,x]; z2=U[y,a,x]; z3=U[y,y,a,x];
z1**(z2**z3)-(z1**z2)**z3 // Simp