Pensieve header: Verifying the commutation relations of frakg_1.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\OneCo-1606"];
<< OneCo.m

Testing (Subscript[g, 1])

(Subscript[a, 1,2])

Table[x->B[U@x,(Subscript[a, 1,2])], {x,{(Subscript[c, 1]),(Subscript[c, 2]),(Subscript[u, 1]),(Subscript[u, 2]),(Subscript[w, 1]),(Subscript[w, 2]),(Subscript[c, 3]),(Subscript[u, 3]),(Subscript[w, 3])}}] // Column

B[(Subscript[a, 1,3]),(Subscript[a, 2,3])]+B[(Subscript[a, 1,2]),(Subscript[a, 2,3])]+B[(Subscript[a, 1,2]),(Subscript[a, 1,3])]

{t1=B[(Subscript[a, 1,2]),(Subscript[a, 1,3])], t2=ϵ U@(Subscript[c, 3])**(Subscript[a, 1,2])-ϵ U@(Subscript[c, 2])**(Subscript[a, 1,3]), t1-t2} // Expand // Column

{t1=B[(Subscript[a, 1,3]),(Subscript[a, 2,3])], t2=(Subscript[bc, 2])**(Subscript[a, 1,3])-(Subscript[bc, 1])**(Subscript[a, 2,3]), t1-t2} // Expand // Column

{t1=(Subscript[a, 1,3])**(Subscript[a, 2,4])-(Subscript[a, 1,4])**(Subscript[a, 2,3]),
t2=(Subscript[a, 1,3])**(Subscript[bc, 2])**U@(Subscript[c, 4])-(Subscript[a, 2,3])**(Subscript[bc, 1])**U@(Subscript[c, 4])-(Subscript[a, 1,4])**(Subscript[bc, 2])**U@(Subscript[c, 3])+(Subscript[a, 2,4])**(Subscript[bc, 1])**U@(Subscript[c, 3]),
t1-t2
} // Column

LBasis[2]

bas=LBasis[2];Table[B[x,y]+B[y,x], {x,bas},{y,bas}] //Flatten//Union

bas=LBasis[2]; Timing[
Table[
{x,y,z}=xyz;
Simp[B[B[x,y],z]+B[B[y,z],x]+B[B[z,x],y]],
{xyz, Subsets[bas,{3}]}
] //Flatten//Union
]

Infinitesimal Spinner Relations

(Subscript[s, i_]):=((Subscript[b, i])/2)U[]-ϵ U[(Subscript[c, i])]

(Subscript[a, 1,2])

B[(Subscript[a, 1,2]),(Subscript[s, 1])]

B[(Subscript[a, 1,2]),(Subscript[s, 2])]

B[(Subscript[a, 1,2]),(Subscript[s, 1])+(Subscript[s, 2])]//Simplify

B[(Subscript[a, 1,3]),(Subscript[a, 2,3])]

Simplify[(Subscript[b, 1]) UU[(Subscript[u, 1]),(Subscript[w, 3])]-(Subscript[b, 1]) UU[(Subscript[u, 1]), (Subscript[w, 3])]+ϵ UU[(Subscript[c, 1]),(Subscript[u, 1]),(Subscript[w, 3])]-ϵ UU[(Subscript[u, 1]),(Subscript[c, 1]),(Subscript[w, 3])]]

Testing bi-local exponential relations in (Subscript[g, 0])

The Yang-Baxter Element.

c Relations.

B[U[c],U[u,w]]

With[{n=7}, Collect[
UExp[β U@u,n]**UExp[α U@c,n]-UExp[α U@c,n]**UExp[(E^(-α))β U@u,n],
_U,Series[#,{α,0,n}]&
]]

With[{n=7}, Collect[
UExp[β U@w,n]**UExp[α U@c,n]-UExp[α U@c,n]**UExp[(E^α)β U@w,n],
_U,Series[#,{α,0,n}]&
]]

u,w,(e^u),(e^w).

With[{n=10},Simp[B[U@w,UExp[γ U@u,n]] + (b γ U[]-2γ ϵ U[c]+ϵ (γ^2)U[u])** UExp[γ U@u,n]]]

With[{n=7},Simp[B[U@u,UExp[γ U@w,n]] - (b γ U[]-2γ ϵ U[c]-ϵ (γ^2)U[w])** UExp[γ U@w,n]]]

(Subscript[M, uw]) Relations.

Muw[γ_,n_] := Expand[(∑_(k=0)^n)((γ^k)/(k!))UU[(u^k),(w^k)]]

Muw[γ,5]

With[{n=12},Muw[γ,n]**U[u]-((1-b γ-2 γ ϵ )U[u]+2 γ ϵ U[c,u]-(((1-b γ))^(-1))(γ^2) ϵ U[u,u,w])**Muw[γ,n]] // Simplify // Expand

With[{n=7}, Simplify[B[U[w],Muw[γ,n]]+b γ Muw[γ,n]**U[w]]]

With[{n=7}, Simplify[
((∂_α)Muw[γ[α],n])-((γ'[α])/(1-b γ[α]))Muw[γ[α],n]**U[u,w]
]]

(Subscript[M, wu]) Relations.

Mwu[γ_,n_] := Expand[(∑_(k=0)^n)((γ^k)/(k!))UU[(w^k),(u^k)]]

With[{n=7}, {t1=Simplify[B[U[u],Mwu[δ,n]]-b δ Mwu[δ,n]**U[u]], t1//ToDegree[n]}]

With[{n=7}, {t1=Simp[B[U[w],Mwu[δ,n]]+b δ U[w]**Mwu[δ,n]], t1//ToDegree[n]}]

With[{n=7}, {t1=Simplify[
((∂_α)Mwu[α δ,n])-(δ/(1+b α δ))Mwu[α δ,n]**U[w]**U[u]
], t1//ToDegree[n]}]

With[{n=7}, Simplify[
((∂_α)Mwu[α δ,n])-(δ/(1+b α δ))Mwu[α δ,n]**(U[u,w]-b U[])
]]

(Subscript[M, wu]) and (Subscript[M, uw]).

With[{n=10, ν=(((1+b δ))^(-1))}, t1=Simp[
-Mwu[δ,n]+(ν(1-(ν^2)b (δ^2)ϵ)U[]+2(ν^2)δ ϵ U[c])**Muw[ν δ,n]+(-2(ν^4)b (δ^3) ϵU[u]+2 (ν^3)(δ^2) ϵU[c,u])**Muw[ν δ,n]**U[w]-((b (ν^5) (δ^4) ϵ)/2)U[u,u]**Muw[ν δ,n]**U[w,w]
]//ToDegree[n]]

Coefficient[t1, U[u,u,w,w]] /. ℏ->1

Series[((b (δ^4) ϵ)/(2(((1+b δ))^5))),{b,0,7}] // Normal

Simplify[((1/(1+b δ))+((-b (δ^2)ϵ)/(((1+b δ))^3)))]

Hard core uw relations.

With[{n=3}, Simp[
UExp[α ℏ U@w,n]**UExp[β U@u,n]-(E^(-b ℏ α β)) UExp[β U@u,n]**UExp[α ℏ U@w,n]
] // ToDegree[n]]

n=14; With[{ν=(((1+b δ))^(-1))},
LHS=Expand[(E^(b ℏ ν α β ))Sum[
(((((α ℏ))^n1)(δ^n2)(β^n3))/(n1!n2!n3!))UU[(w^(n1+n2)),(u^(n2+n3))],
{n1,0,n},{n2,0,n-n1},{n3,0,n-n1-n2}
]];
RHS=Expand[ν Sum[
(((((ν β))^n1)(((ν δ))^n2)(((ν α ℏ))^n3))/(n1!n2!n3!))UU[(u^(n1+n2)),(w^(n2+n3))],
{n1,0,n},{n2,0,n-n1},{n3,0,n-n1-n2}
]];
]

t1=With[{ν=(((1+b δ))^(-1))},Simp[ToDegree[14][-LHS+
RHS - (1/2) b ϵ (ν^2) (2 (δ^2)+4 α β δ ν+(α^2) (β^2) (ν^2))RHS+2 ϵ ν(δ+α β ν)U[c]**RHS-β (1+2 b δ) ϵ (ν^3) (2 δ+α β ν)U[u]**RHS+α ϵ (ν^3) (2 δ+α β ν)RHS**U[w]+2 β δ (ν^2) ϵ U[c,u]**RHS+2 α δ (ν^2) ϵ U[c]**RHS**U[w]-(1/2) (β^2) δ (2+3 b δ) ϵ (ν^4)U[u,u]**RHS+(1/2) (α^2) δ (2+b δ) ϵ (ν^4)RHS**U[w,w]-2 b (δ^2) ϵ (ν^3) (δ+α β ν)U[u]**RHS**U[w]+2 (δ^2) (ν^2) ϵ U[c,u]**RHS**U[w]-β (δ^2) (1+2 b δ) ϵ (ν^4)U[u,u]**RHS**U[w]+α (δ^2) (ν^4) ϵU[u]**RHS**U[w,w]-(1/2) b (δ^4)(ν^4) ϵ U[u,u]**RHS**U[w,w]
]]];
t1 /. ϵ->0

Expand[t1] /. a_.x_U /; (Count[x,u]+Exponent[a,b]+Exponent[a,α])>14 :> 0

Take[Cases[t1, _U, ∞] // Sort, 30]

t2=Collect[Coefficient[t1, U[w,w,w,w]] // Simplify, β, Simplify]

Sum[FindSequenceFunction[CoefficientList[
1-3 b δ+5 (b^2) (δ^2)-5 (b^3) (δ^3)+14 (b^5) (δ^5)-42 (b^6) (δ^6)+90 (b^7) (δ^7)-165 (b^8) (δ^8)+275 (b^9) (δ^9)-429 (b^10) (δ^10)
,b ] /. δ->1][k+1](((b δ))^k), {k,0,∞}]

t3=With[{ν=(((1+b δ))^(-1))}, Series[
(1/2) b (δ^4)(ν^5) ϵ,
{b,0,12}]] // Normal//Simplify

Series[t2-t3, {b,0,8}]

Simplify[β (δ^2) (1+2 b δ )(ν^4)ϵ]

Logos and testing

Logos[M_, ν_]:= - (1/2) b  ν (2 (δ^2)+4 α β δ ν+(α^2) (β^2) (ν^2))M+2  (δ+α β ν)U[c]⊗M-β (1+2 b δ)  (ν^2) (2 δ+α β ν)U[u]⊗M+α  (ν^2) (2 δ+α β ν)M⊗U[w]+2 β δ ν  U[c,u]⊗M+2 α δ ν  U[c]⊗M⊗U[w]-(1/2) (β^2) δ (2+3 b δ)  (ν^3)U[u,u]⊗M+(1/2) (α^2) δ (2+b δ)  (ν^3)M⊗U[w,w]-2 b (δ^2)  (ν^2) (δ+α β ν)U[u]⊗M⊗U[w]+2 (δ^2) ν  U[c,u]⊗M⊗U[w]-β (δ^2) (1+2 b δ)  (ν^3)U[u,u]⊗M⊗U[w]+α (δ^2) (ν^3) U[u]⊗M⊗U[w,w]-(1/2) b (δ^4)(ν^3)  U[u,u]⊗M⊗U[w,w];
With[{n=10, ν=(((1+b δ))^(-1))},
LHS=Expand[Sum[
(((((α ))^n1)(δ^n2)(β^n3))/(n1!n2!n3!))UU[(w^(n1+n2)),(u^(n2+n3))],
{n1,0,n},{n2,0,n-n1},{n3,0,n-n1-n2}
]];
RHS=Expand[ν (E^(-b  ν α β )) Sum[
(((((ν β))^n1)(((ν δ))^n2)(((ν α ))^n3))/(n1!n2!n3!))UU[(u^(n1+n2)),(w^(n2+n3))],
{n1,0,n},{n2,0,n-n1},{n3,0,n-n1-n2}
]];
t1=Simp[-LHS+RHS+ϵ ν Logos[RHS, ν] /. TensorProduct->NonCommutativeMultiply]
];
t1 /. ϵ->0

((O[ℏ])^11)+(t1 /. ϵ->0 /. a_.x_U :>  (a/. {b->ℏ b, α->ℏ α})(ℏ^(Count[x,u]))x)

((O[ℏ])^11)+(t1  /. a_.x_U :>  (a/. {b->ℏ b, α->ℏ α, ϵ->ℏ ϵ})(ℏ^(Count[x,u]))x)

logos=Logos[1, ν] /. TensorProduct|U -> Times

Λ=(Collect[Simplify[logos], {c,u,w}, C[Simplify[#]]&]//Expand)/.C[x_]:>x

Λ//TeXForm

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