Pensieve header: Testing the Logos.

Testing the Logos

Finding the Logos

(Logos=Λ(Overscript[ο, '])γοϛ, “a principle of order an knowledge”)

(Subscript[DP, x_->(Subscript[D, α_]),y_->(Subscript[D, β_])])[P_][f_]:=Total[CoefficientRules[P,{x,y}]/.({m_,n_}->c_):>c D[f,{α,m},{β,n}]]

(Subscript[Λ, k_])[h_,e_,l_,f_,α_,β_,δ_] :=(Subscript[Λ, k])[h,e,l,f,α,β,δ]=Module[{λ},
λ=Normal@Series[(E^((f α+e β)/(1-α β ϵ))) (((1-α β ϵ))^(-2 l+(h/ϵ))), {ϵ,0,k}]/.(E^(_))->1;
Collect[(Subscript[DP, α->(Subscript[D, f]),β->(Subscript[D, e])])[λ][(E^((f α+e β+e f δ)/(1+h δ)))]/.(E^(_))->1,ϵ,Simplify]];

Implementing (𝔤^ϵ)=⟨h,e,l,f⟩/([e,l]=-e, [f,l]=f, [e,f]=h-2ϵ l, [h,*]=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];

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

Aside

(Subscript[r, i_,j_]):=(Subscript[h, i])UU[(Subscript[l, j])]-ϵ UU[(Subscript[l, i]),(Subscript[l, j])]+UU[(Subscript[e, i]),(Subscript[f, j])];
B[(Subscript[r, 1,2]),(Subscript[r, 1,3])]+B[(Subscript[r, 1,2]),(Subscript[r, 2,3])]+B[(Subscript[r, 1,3]),(Subscript[r, 2,3])]

The main (Subscript[𝔤, k]) lemma, hardest part only

In (𝔤^ϵ)=⟨h,e,l,f⟩/([e,l]=-e, [f,l]=f, [e,f]=h-2ϵ l, [h,*]=0) and at (ϵ^(k+1))=0, we have
𝕆((e^(βe+αf+δef))|fe)=𝕆(((νe)^(ν(-αβh+βe+αf+δef)))(Subscript[Λ, k])(ϵ,e,l,f,α,β,δ)|ef),
with ν=(((1+hδ))^(-1)) and where (Subscript[Λ, k])(ϵ,e,l,f,α,β,δ) is as above.

degrule={α->ℏ α,h->ℏ (Subscript[h, 1]),e->ℏ (Subscript[e, 1]),l->(Subscript[l, 1]),f->(Subscript[f, 1]),ϵ->ℏ ϵ};

k=1; $TD=6; Clear[ϵ];  ϵ /: (ϵ^(k+1))=0;
Simp[ 𝕆[(E^(α f+β e+δ e f))/.degrule, {(Subscript[f, 1]),(Subscript[e, 1])}->1]-𝕆[ν (Subscript[Λ, k])[h,e,l,f,α,β,δ] (E^(ν(-α β h+α f+β e+δ e f)))/.ν->(((1+h δ))^(-1))/.degrule,{(Subscript[e, 1]),(Subscript[l, 1]),(Subscript[f, 1])}->1]]

k=2; $TD=10; Clear[ϵ];  ϵ /: (ϵ^(k+1))=0;
Simp[ 𝕆[(E^(α f+β e+δ e f))/.degrule, {(Subscript[f, 1]),(Subscript[e, 1])}->1]-𝕆[ν (Subscript[Λ, k])[h,e,l,f,α,β,δ] (E^(ν(-α β h+α f+β e+δ e f)))/.ν->(((1+h δ))^(-1))/.degrule,{(Subscript[e, 1]),(Subscript[l, 1]),(Subscript[f, 1])}->1]]

k=3; $TD=12; Clear[ϵ];  ϵ /: (ϵ^(k+1))=0;
Simp[ 𝕆[(E^(α f+β e+δ e f))/.degrule, {(Subscript[f, 1]),(Subscript[e, 1])}->1]-𝕆[ν (Subscript[Λ, k])[h,e,l,f,α,β,δ] (E^(ν(-α β h+α f+β e+δ e f)))/.ν->(((1+h δ))^(-1))/.degrule,{(Subscript[e, 1]),(Subscript[l, 1]),(Subscript[f, 1])}->1]]

k=2; $TD=8; Clear[ϵ];  ϵ /: (ϵ^(k+1))=0;
Print[Short[lhs=Timing[ 𝕆[(E^(α f+β e+δ e f))/.degrule, {(Subscript[f, 1]),(Subscript[e, 1])}->1]]]];
Print[Short[rhs=Timing[𝕆[ν (Subscript[Λ, k])[h,e,l,f,α,β,δ] (E^(ν(-α β h+α f+β e+δ e f)))/.ν->(((1+h δ))^(-1))/.degrule,{(Subscript[e, 1]),(Subscript[l, 1]),(Subscript[f, 1])}->1]]]];
lhs-rhs