Pensieve header: Working in the double of the 2D pencil, as determined in “Doubling.nb”; continued pensieve://2017-08/.

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

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

(*$TD=∞; ℏ /: (ℏ^(d_. ))/;d>$TD :=0;*)
$TβD=2; β /: (β^(d_. ))/;d>$TβD :=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[(ℏ^(-1))(1-(E^(ℏ t-"2" ℏ ββ a))), {ββ,0,5}]

q:=Sum[((((ℏ α β))^k)/(k!)), {k,0,Min[$TβD]}];
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}];*)
B[U@x,U@y]:=(q-1)UU[y,x]+UU[(ℏ^(-1))(1-Sum[T(((-2 a β ℏ))^k)/k! ,{k,0,$TβD}])];

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

(Subscript[U, i_])[ℰ_] := ℰ /. {t->(Subscript[t, 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_]]=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:AlgebraAtom))^(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))]
]

$TβD=5; B[U@x,U@y]//Simp

$TβD=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

adx[ℰ_] := B[U@x, ℰ];
$TβD=2; Simp[NestList[adx, U@y, $TβD+2]]

G=Simp[NestList[adx, U@y, $TβD+1].Table[(μ^k)/k!, {k,0, $TβD+1}]]

$TβD=0;
adx[ℰ_] := B[U@x, ℰ];
G=Simp[NestList[adx, U@y, $TβD+1].Table[(μ^k)/k!, {k,0, $TβD+1}]];
F0=(E^(-(((-μ+T μ) ν)/ℏ)));
F=Sum[F0 (Subscript[f, l,i,j,k])[ν](β^l)UU[(y^i),(a^j),(x^k)],{l,0,$TβD},{i,0, l},{j,0, l},{k,0, Min[l,2l-i-j]}];
unowns=Cases[F, (Subscript[f, ___])[ν],∞];
bas=Union@@Table[(β^l)Cases[Coefficient[F,β,l],_U,∞], {l,0,$TβD}];
eqns=Flatten[{(Coefficient[F-U[], #]/.ν->0)==0, Expand[(F0^(-1))Coefficient[Simp[F**G-U[y]**F-(∂_ν)F], #]]==0}& /@ bas];
{sol}=DSolve[eqns, unowns, ν];
FF=Simp[(F0^(-1))F /. sol];
LFF=Simp@Sum[
SeriesCoefficient[Log[1+x],{x,0,k}]*NonCommutativeMultiply@@Table[FF-U[],{k}],
{k,0,$TβD}]

$TβD=1;
adx[ℰ_] := B[U@x, ℰ];
G=Simp[NestList[adx, U@y, $TβD+1].Table[(μ^k)/k!, {k,0, $TβD+1}]];
F0=(E^(-(((-μ+T μ) ν)/ℏ)));
F=Sum[F0 (Subscript[f, l,i,j,k])[ν](β^l)UU[(y^i),(a^j),(x^k)],{l,0,$TβD},{i,0, l},{j,0, l},{k,0, Min[l,2l-i-j]}];
unowns=Cases[F, (Subscript[f, ___])[ν],∞];
bas=Union@@Table[(β^l)Cases[Coefficient[F,β,l],_U,∞], {l,0,$TβD}];
eqns=Flatten[{(Coefficient[F-U[], #]/.ν->0)==0, Expand[(F0^(-1))Coefficient[Simp[F**G-U[y]**F-(∂_ν)F], #]]==0}& /@ bas];
{sol}=DSolve[eqns, unowns, ν];
FF=Simp[(F0^(-1))F /. sol];
LFF=Simp@Sum[
SeriesCoefficient[Log[1+x],{x,0,k}]*NonCommutativeMultiply@@Table[FF-U[],{k}],
{k,0,$TβD}]

$TβD=2;
adx[ℰ_] := B[U@x, ℰ];
G=Simp[NestList[adx, U@y, $TβD+1].Table[(μ^k)/k!, {k,0, $TβD+1}]];
F0=(E^(-(((-μ+T μ) ν)/ℏ)));
F=Sum[F0 (Subscript[f, l,i,j,k])[ν](β^l)UU[(y^i),(a^j),(x^k)],{l,0,$TβD},{i,0, l},{j,0, l},{k,0, Min[l,2l-i-j]}];
unowns=Cases[F, (Subscript[f, ___])[ν],∞];
bas=Union@@Table[(β^l)Cases[Coefficient[F,β,l],_U,∞], {l,0,$TβD}];
eqns=Flatten[{(Coefficient[F-U[], #]/.ν->0)==0, Expand[(F0^(-1))Coefficient[Simp[F**G-U[y]**F-(∂_ν)F], #]]==0}& /@ bas];
{sol}=DSolve[eqns, unowns, ν];
FF=Simp[(F0^(-1))F /. sol];
LFF=Simp@Sum[
SeriesCoefficient[Log[1+x],{x,0,k}]*NonCommutativeMultiply@@Table[FF-U[],{k}],
{k,0,$TβD}]

$TβD=3;
adx[ℰ_] := B[U@x, ℰ];
G=Simp[NestList[adx, U@y, $TβD+1].Table[(μ^k)/k!, {k,0, $TβD+1}]];
F0=(E^(-(((-μ+T μ) ν)/ℏ)));
F=Sum[F0 (Subscript[f, l,i,j,k])[ν](β^l)UU[(y^i),(a^j),(x^k)],{l,0,$TβD},{i,0, l},{j,0, l},{k,0, Min[l,2l-i-j]}];
unowns=Cases[F, (Subscript[f, ___])[ν],∞];
bas=Union@@Table[(β^l)Cases[Coefficient[F,β,l],_U,∞], {l,0,$TβD}];
eqns=Flatten[{(Coefficient[F-U[], #]/.ν->0)==0, Expand[(F0^(-1))Coefficient[Simp[F**G-U[y]**F-(∂_ν)F], #]]==0}& /@ bas];
{sol}=DSolve[eqns, unowns, ν];
SortBy[sol,#[[2]]&]

FF=Simp[(F0^(-1))F /. sol];
{FF /. ν->0, Simp[F0 FF**G-F0 U[y]**FF-(∂_ν)(F0 FF)]}

FF

LFF=Simp@Sum[
SeriesCoefficient[Log[1+x],{x,0,k}]*NonCommutativeMultiply@@Table[FF-U[],{k}],
{k,0,$TβD}]

Cases[FF, _U,∞]

Cases[LFF, _U,∞]