Pensieve header: Verifying the commutation relations of frakg_0.

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

Testing (Subscript[g, 0])

(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
]

(#->Ea[τ,i,j][U@#]-AutoEa[τ,i,j][U@#])& /@ {(Subscript[c, i]),(Subscript[c, j]),(Subscript[u, i]),(Subscript[u, j]),(Subscript[w, i]),(Subscript[w, j])}

bas=U/@Flatten@Table[(Subscript[y, k]), {y,{c,u,w}}, {k,3}];
Table[{x,y}->Expand[Ea[τ,1,2][B[x,y]]-B[Ea[τ,1,2][x], Ea[τ,1,2][y]]], {x,bas},{y,bas}]

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

The Yang-Baxter Element.

(Subscript[a, 1,2])

UExp[(Subscript[a, 1,2]),3] // ToDegree[3]

With[{n=10}, Simp[
UExp[(Subscript[a, 1,2]), n]-UExp[(Subscript[b, 1])U[(Subscript[c, 2])],n]**UExp[(((E^(Subscript[b, 1]))-1)/(Subscript[b, 1]))U[(Subscript[u, 1]),(Subscript[w, 2])], n]
]// ToDegree[n]]

Aside - testing R3:

With[{n=3},Simp[
(UExp[(Subscript[a, 1,2]), n]**UExp[(Subscript[a, 1,3]), n]**UExp[(Subscript[a, 2,3]), n])-(UExp[(Subscript[a, 2,3]), n]**UExp[(Subscript[a, 1,3]), n]**UExp[(Subscript[a, 1,2]), n])// ToDegree[n]
]]

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 γ UExp[γ U@u,n]]]

With[{n=7},Simp[B[U@u,UExp[γ U@w,n]] - b γ UExp[γ U@w,n]]]

(Subscript[M, uw]) Relations.

Muw[γ_,n_] := Expand[(∑_(k=0)^n)((γ^k)/(k!))(U@@Table[u,{k}])**(U@@Table[w,{k}])]

With[{n=12}, Simplify[B[U[u],Muw[γ,n]]-b γ U[u]**Muw[γ,n]]]

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!))(U@@Table[w,{k}])**(U@@Table[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]).

DSolve[(δ/(1+b α δ))==((γ'[α])/(1-b γ[α]))∧γ[0]==0, γ[α],α]

With[{n=7}, {t1=Simp[
Mwu[α δ,n]-(Muw[((α δ)/(1+α b δ)),n]**((1/(1+α b δ))U[]))
], t1//ToDegree[n]}]

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]]

With[{n=5, ν=(((1+b δ))^(-1))}, Simp[
UExp[α ℏ U@w,n]**Mwu[δ,n]**UExp[β U@u,n]
-ν (E^(-b ℏ ν α β ))  UExp[ν β U@u   ,n]**Muw[ν δ,n]**UExp[ν α ℏ U@w,n]
] // ToDegree[n]]