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

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

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

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

The Logos and Testing

From Classes:17-1350-AKT:170317-g1Invariant@.nb:

(Subscript[Λ, k_])[h_,e_,l_,f_,α_,β_,δ_]:=Module[
{ρh,ρe,ρl,ρf,eqn,a,b,c,sol,λ,q,ν},
ρh=(({{-1, 0}, {0, -1}}));  ρe=(({{0, 0}, {-ϵ, 0}}));  ρl=(({{-(1+1/ϵ)/2, 0}, {0, (1-1/ϵ)/2}})); ρf=(({{0, 1}, {0, 0}}));
eqn=MatrixExp[α ρf].MatrixExp[β ρe]==MatrixExp[a ρe].MatrixExp[c (ρh-2ϵ ρl)].MatrixExp[b ρf];
Echo[sol=Solve[Thread[Flatten/@eqn], {a,b,c}][[1]] /. C[1]->0];
λ=Simplify[(E^(-f α-e β+h α β))Normal@Series[(E^(c h + a e - 2ϵ c l + b f))/.sol, {ϵ,0,k}]];
q=(E^(ν(f α+e β-h α β+e f δ)));
Collect[(q^(-1))(Subscript[DP, α->(Subscript[D, f]),β->(Subscript[D, e])])[λ][q] /. ν->(((1+h δ))^(-1)),ϵ,Simplify]];