Pensieve header: The double and meta-double of the 2D pencil; continues pensieve://2017-05/.

Issues:
1. S does not invert R. (Perhaps because H must be interpreted as (e^(ℏ h))).
2. dm is not meta-associative.
3. R doesn’t satisfy YB.
4. Improve DUForm.

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

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

$TD=3; ℏ /: (ℏ^(d_. ))/;d>$TD :=0;

The 2D Lie BiAlgebra Pencil

We hope to stick to A=(e^(ℏ β a)) and to B=(e^(ℏ α b)), where [a,x]=α x and [b,y]=-β y.
Also, (Subscript[Δ, 12])(a,A,x,b,B,y) = ((Subscript[a, 1])+(Subscript[a, 2]), (Subscript[A, 1])(Subscript[A, 2]), (Subscript[x, 1])+(Subscript[A, 1])(Subscript[x, 2]), (Subscript[b, 1])+(Subscript[b, 2]), (Subscript[B, 1])(Subscript[B, 2]), (Subscript[y, 1])(Subscript[B, 2])+(Subscript[y, 2])).
Also, (a,x) and ℏ(b,y) are dual bases.

AlgebraAtom = a|A[_]|x|b|B[_]|y;
$PBWRule={A[_]->1,a->2,x->3,y->4,B[_]->5,b->6};

B[a,x] = α x; B[x,A[n_]]=((E^(n ℏ α β))-1)U[A[n],x]; B[a,A[_]]=0;
B[y,b] = β y; B[B[n_],y]=((E^(n ℏ α β))-1)U[y,B[n]]; B[b,B[_]]=0;
Δ[a]=(Subscript[U, 1])[a](Subscript[U, 2])[]+(Subscript[U, 1])[](Subscript[U, 2])[a]; Δ[A[n_]]:=(Subscript[U, 1])[A[n]](Subscript[U, 2])[A[n]]; Δ[x]=(Subscript[U, 1])[x](Subscript[U, 2])[]+(Subscript[U, 1])[A[1]](Subscript[U, 2])[x];
Δ[b]=(Subscript[U, 1])[b](Subscript[U, 2])[]+(Subscript[U, 1])[](Subscript[U, 2])[b]; Δ[B[n_]]:=(Subscript[U, 1])[B[n]](Subscript[U, 2])[B[n]]; Δ[y]=(Subscript[U, 1])[y](Subscript[U, 2])[B[1]]+(Subscript[U, 1])[](Subscript[U, 2])[y];
S[a]=-a; S[A[n_]]:=A[-n]; S[x] = - U[A[-1],x];
S[b]=-b; S[B[n_]]:=B[-n]; S[y] = - U[y,B[-1]];
Si[a]=-a; Si[A[n_]]:=A[-n]; Si[x] = - U[x,A[-1]];
Si[b]=-b; Si[B[n_]]:=B[-n]; Si[y] = - U[B[-1],y];
(* This extra line is annoying *)

ExpandAB[ℰ_] := Expand@Normal@Series[ℰ //. {
c_. (Subscript[U, i_])[λ___, A[n_],ρ___] :> Expand[c Sum[(((((-1))^d)(ℏ^d)(β^d)(n^d))/(d!))(Subscript[U, i])[λ,Sequence@@Table[a,{d}],ρ],{d,0,$TD}]],
c_. (Subscript[U, i_])[λ___, B[n_],ρ___] :> Expand[c Sum[(((((-1))^d)(ℏ^d)(α^d)(n^d))/(d!))(Subscript[U, i])[λ,Sequence@@Table[b,{d}],ρ],{d,0,$TD}]]
}, {ℏ,0,$TD}]

UEA with provisional modification

This section is based on penseive://Projects/UEA/.

B[0,_]=0; B[_,0]=0;
B[c_*x:AlgebraAtom,y_]:=Expand[c B[x,y]];
B[y_,c_*x:AlgebraAtom]:=Expand[c B[y,x]];
B[x_Plus,y_] := B[#,y]& /@ x;
B[x_,y_Plus] := B[x,#]& /@ y;
B[x_,x_] =0;
B[y_,x_] := Expand[-B[x,y]];

x_⪯y_:=OrderedQ[{x,y}/.$PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.$PBWRule];
(Subscript[UU, i_])[] := (Subscript[U, i])[]; (Subscript[UU, i_])[1] := (Subscript[U, i])[];
(Subscript[UU, i_])[((x_[n_])^(p_))] := (Subscript[U, i])[x[n p]];
(Subscript[UU, i_])[((x_)^(p_))]:=(Subscript[UU, i])@@Table[x,{p}];
(Subscript[UU, i_])[ℰ_] := ℰ /. {
U[xs__] :> (Subscript[U, i])[xs],
x:AlgebraAtom:>(Subscript[U, i])[x]
};
(Subscript[UU, i_])[x_,xs__] := (Subscript[UU, t1])[x](Subscript[UU, t2])[xs] // Expand // (Subscript[m, t1,t2->i]);
USimp[ℰ_]:= Collect[ℰ, Times[(Subscript[U, _])[__]..], Expand];
USimp[ℰ_]:=Expand[ℰ];

(Subscript[m, s__])[0]=0;
(Subscript[m, s__])[x_Plus] := (Subscript[m, s])/@x;
(Subscript[m, i_->j_])[ℰ_] := ℰ /. (Subscript[U, i])->(Subscript[U, j]);

(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[x___](Subscript[U, j_])[]]:=c (Subscript[U, k])[x];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[](Subscript[U, j_])[y___]]:=c (Subscript[U, k])[y];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[xx___,x_[n1_]](Subscript[U, j_])[x_[n2_],yy___]]:= USimp[c If[n1+n2==0, (Subscript[U, i])[xx](Subscript[U, j])[yy], (Subscript[U, i])[xx,x[n1+n2]](Subscript[U, j])[yy]] // (Subscript[m, i,j->k])];
(Subscript[m, i_,j_->k_])[c_. (Subscript[U, i_])[xx___,x_](Subscript[U, j_])[y_,yy___]]:=If[x⪯y,
c (Subscript[U, k])[xx,x,y,yy],
(((Subscript[U, i])[xx]((Subscript[U, j])[y,x]+(Subscript[UU, j])[B[x,y]]) // Expand // (Subscript[m, i,j->i]))(Subscript[U, j])[yy] // Expand // (Subscript[m, i,j->k]))c // USimp
];

Supp[ℰ_]:= Union@Cases[{ℰ}, (Subscript[U, i_])[___]:>i, ∞];

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
x_**y_ := Module[
{Sx=Supp[x], Sy=Supp[y],is,σ,z},
If[MatchQ[Sx⋃Sy,{_Integer...}]&&Min[Sx⋃Sy]<0,
is=Abs[Sx]⋂Abs[Sy];
z=x; Do[z=(Subscript[m, -i->-σ@i])[(Subscript[m, i->σ@i])[z]], {i,is}];
z=USimp[y z]; Do[z=(Subscript[dm, σ@i,i->i])[z], {i,is}];
z,
(* else *) is=Sx⋂Sy;
z=x; Do[z=(Subscript[m, i->σ@i])[z], {i,is}];
z=USimp[y z]; Do[z=(Subscript[m, σ@i,i->i])[z], {i,is}];
z
]
];
UB[x_,y_] := USimp[x**y-y**x];

𝕆[func_] := Normal@Series[func,{ℏ,0,$TD}];
𝕆[specs_, func_] := Module[{rules,vars,elems},
rules=Union@@Cases[{specs}, (Subscript[U, _])[u___]:>Cases[{u},r_Rule], ∞];
vars=First/@rules; elems=Last/@rules;
USimp@Total[CoefficientRules[𝕆[func], vars] /. (ps_ -> c_) :> c(
specs /. MapThread[((#1->_) :> ((#3)^(#2)))&,{vars,ps,elems}] /. (Subscript[U, i_]):>(Subscript[UU, i])
)]
]

The 2D Lie BiAlgebra Pencil, Testing

𝕆[(Subscript[U, 1])[a->a], (E^(ℏ β a))]

USimp@With[{An=𝕆[(Subscript[U, 1])[a->a], (E^(-n ℏ β a))]}, UB[(Subscript[U, 1])[x],An]-𝕆[(E^(n ℏ α β))-1]An**(Subscript[U, 1])[x]]

B[x,A[3]]

$TD=6;
USimp@With[{Bn=𝕆[(Subscript[U, 1])[b->b],(E^(-n ℏ α b))]}, UB[Bn,(Subscript[U, 1])[y]]-𝕆[(E^(n ℏ α β))-1](Subscript[U, 1])[y]**Bn]

z=(Subscript[U, 1])[a,A[2],x,x,x](Subscript[U, 2])[a,a,x](Subscript[U, 3])[a,a,A[-3],x];
(z // (Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))-(z // (Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

z=(Subscript[U, 1])[y,y,y,b,B[2]](Subscript[U, 2])[y,b,b](Subscript[U, 3])[y,b,b,B[-3]];
(z// (Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))-(z // (Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

The Co-Product and Co-Associativity

(Subscript[Δ, i_->j_,k_])[ℰ_] := USimp@Module[{tj,tk}, ℰ /. {
(Subscript[U, i])[] -> (Subscript[U, j])[](Subscript[U, k])[],
(Subscript[U, i])[f_,fs___] :> (USimp[(Δ[f]/. {(Subscript[U, 1])->(Subscript[U, j]),(Subscript[U, 2])->(Subscript[U, k])})(Subscript[Δ, i->tj,tk])[(Subscript[U, i])[fs]]]  // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k]))
}];
(Subscript[Δ, i_->j_,k_,l__])[ℰ_] := ℰ // (Subscript[Δ, i->j,k])//(Subscript[Δ, k->k,l])

(Subscript[Δ, 1->1,2])[(Subscript[U, 1])[#]]& /@ {a,A[7],x,y,b,B[-3]}

{lhs=(Subscript[U, 1])[x] // (Subscript[Δ, 1->1,2]) // (Subscript[Δ, 2->2,3]), rhs=(Subscript[U, 1])[x] // (Subscript[Δ, 1->1,3]) // (Subscript[Δ, 1->1,2]), lhs==rhs}

(Subscript[U, 1])[y] // (Subscript[Δ, 1->1,2])

{lhs=(Subscript[U, 1])[y] // (Subscript[Δ, 1->1,2]) // (Subscript[Δ, 2->2,3]), rhs=(Subscript[U, 1])[y] // (Subscript[Δ, 1->1,3]) // (Subscript[Δ, 1->1,2]), lhs==rhs}

z=(Subscript[U, 1])[a,A[2],x,x,x](Subscript[U, 2])[a,a,A[-3],x];
(z // (Subscript[m, 1,2->1]) // (Subscript[Δ, 1->1,2]))-(z//(Subscript[Δ, 2->3,4])//(Subscript[Δ, 1->1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))

z=(Subscript[U, 1])[y,y,y,b,B[2]](Subscript[U, 2])[y,b,b,B[-3]];
(z// (Subscript[m, 1,2->1]) // (Subscript[Δ, 1->1,2]))-(z//(Subscript[Δ, 2->3,4])//(Subscript[Δ, 1->1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))

The Antipode

(Subscript[S, i_])[ℰ_] := Module[{ti}, USimp[
ℰ /. (Subscript[U, i])[x_,xs___] :> (Subscript[m, ti,i->i])[Expand[(Subscript[UU, i])[S[x]](Subscript[S, ti])[(Subscript[U, ti])[xs]]]]
]];
(Subscript[Si, i_])[ℰ_] := Module[{ti}, USimp[
ℰ /. (Subscript[U, i])[x_,xs___] :> (Subscript[m, ti,i->i])[Expand[(Subscript[UU, i])[Si[x]](Subscript[Si, ti])[(Subscript[U, ti])[xs]]]]
]];

{(Subscript[U, 1])[x] // (Subscript[S, 1]) // (Subscript[S, 1]), (Subscript[U, 1])[y] // (Subscript[S, 1]) // (Subscript[S, 1])}

{(Subscript[U, 1])[x] // (Subscript[S, 1]) // (Subscript[Si, 1]), (Subscript[U, 1])[y] // (Subscript[S, 1]) // (Subscript[Si, 1])}

{z=(Subscript[U, 1])[]; (z//(Subscript[Δ, 1->1,2])//(Subscript[S, 1])//(Subscript[m, 1,2->1])), z=(Subscript[U, 1])[]; (z//(Subscript[Δ, 1->1,2])//(Subscript[S, 2])//(Subscript[m, 1,2->1]))}

z=(Subscript[U, 1])[a,A[3],x,x];
{z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 1,2->1]),  z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 1,2->1])}

z=(Subscript[U, 1])[y,y,y,b,B[-3]];
{z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 1,2->1]), z // (Subscript[Δ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 1,2->1])}

{z=(Subscript[U, 1])[a,A[2],x,x,x](Subscript[U, 2])[a,a,A[-3],x]; (z//(Subscript[m, 1,2->1])//(Subscript[S, 1]))-(z//(Subscript[S, 1])//(Subscript[S, 2])//(Subscript[m, 2,1->1])),
z=(Subscript[U, 1])[y,y,y,b,B[2]](Subscript[U, 2])[y,b,b,b,B[6]]; (z//(Subscript[m, 1,2->1])//(Subscript[S, 1]))-(z//(Subscript[S, 1])//(Subscript[S, 2])//(Subscript[m, 2,1->1]))}

{z=(Subscript[U, 1])[a,A[2],x,x,x]; (z//(Subscript[S, 1]) //(Subscript[Δ, 1->2,1]))-(z//(Subscript[Δ, 1->1,2])//(Subscript[S, 1])//(Subscript[S, 2])),
z=(Subscript[U, 1])[y,y,y,b,B[2]]; (z//(Subscript[S, 1]) //(Subscript[Δ, 1->2,1]))-(z//(Subscript[Δ, 1->1,2])//(Subscript[S, 1])//(Subscript[S, 2]))
}

The Pairing

P[U[], U[B[_]]] = P[U[A[_]],U[]] = 1;
P[U[], U[__]] = P[U[__],U[]] = 0;
(({{P[U[a],U[b]]=(ℏ^(-1)), P[U[a],U[B[n_]]]=-n α, P[U[a],U[y]]=0}, {P[U[A[n_]],U[b]]=-n β, P[U[A[n_]],U[B[m_]]]=(E^(n m ℏ α β )), P[U[A[_]],U[y]]=0}, {P[U[x],U[b]]=0, P[U[x],U[B[_]]]=0, P[U[x],U[y]]=(ℏ^(-1))}}));

P[U[],U[]] = 1;
(Subscript[P, i_,j_])[ℰ_] := USimp[ℰ /. (Subscript[U, i])[xs___](Subscript[U, j])[ys___] -> P[U[xs],U[ys]]];

The pairing sequence: ⟨one,one⟩ (above), ⟨many,one⟩, ⟨many,many⟩.

P[U[x_,xs__], U[y_]] := P[U[x,xs],U[y]] = Module[{i,j,k,l}, USimp[(Subscript[U, i])[x](Subscript[UU, j])[xs](Subscript[Δ, k->k,l])[(Subscript[U, k])[y]]] // (Subscript[P, i,k]) // (Subscript[P, j,l])];
P[U[xs__],U[y_,ys__]] := P[U[xs],U[y,ys]] = Module[{i,j,k,l}, USimp[(Subscript[Δ, i->i,j])[(Subscript[UU, i])[xs]](Subscript[U, k])[y](Subscript[UU, l])[ys]] // (Subscript[P, i,k]) // (Subscript[P, j,l])];

z=(Subscript[U, i])[a](Subscript[U, j])[x](Subscript[U, k])[y];
{(Subscript[m, i,j->i])[z]-(Subscript[m, j,i->i])[z], (Subscript[Δ, k->k,l])[z]-(Subscript[Δ, k->l,k])[z]}

Table[z=(Subscript[U, i])[xi](Subscript[U, j])[xj](Subscript[U, k])[yk];
{((Subscript[m, i,j->i])[z]-(Subscript[m, j,i->i])[z])//(Subscript[P, i,k]), ((Subscript[Δ, k->k,l])[z]-(Subscript[Δ, k->l,k])[z]) // (Subscript[P, i,k])//(Subscript[P, j,l])},
{xi,{a,x}}, {xj,{a,x}}, {yk,{b,y}}]

Table[z=(Subscript[U, i])[xi](Subscript[U, k])[yk](Subscript[U, l])[yl];
{((Subscript[Δ, i->i,j])[z]-(Subscript[Δ, i->j,i])[z])//(Subscript[P, i,k])//(Subscript[P, j,l]), ((Subscript[m, k,l->k])[z]-(Subscript[m, l,k->k])[z]) // (Subscript[P, i,k])},
{xi,{a,x}}, {yk,{b,y}}, {yl,{b,y}}]

lhs=Factor@Table[(ℏ^n)P[U@@Table[x,{n}], U@@Table[y,{n}]], {n,$TD=7}]

rhs=Simplify@FunctionExpand@Table[QFactorial[n,(E^(ℏ α β))], {n,$TD=7}]

MapThread[Equal,{lhs,rhs}]

P[U[a,a,a,a,a],U[b,b,b,b,b]]

Table[P[z1,z2],
{z1, {U[], U[a], U[x], U[a,a],U[a,x],U[x,x],U[a,a,a],U[a,a,x],U[a,x,x],U[x,x,x]}}, {z2, {U[], U[b], U[y], U[b,b],U[y,b],U[y,y],U[b,b,b],U[y,b,b],U[y,y,b],U[y,y,y]}}
] // MatrixForm

The Double

DUForm[ℰ_] := ℰ //. (Subscript[U, i_])[fs___](Subscript[U, j_])[gs___] /; i+j==0 :> (Subscript[DU, Abs@i])[fs,gs];

(Subscript[dm, i_,j_->k_])[ℰ_] := Module[{t1,t2,t3,h1,h2,h3},
ℰ // (Subscript[Δ, i->h1,h2,h3])//(Subscript[S, h3])//(Subscript[Δ, -j->t1,t2,t3])//(Subscript[P, h1,t1])//(Subscript[P, h3,t3])//(Subscript[m, j,h2->k])//(Subscript[m, -i,t2->-k])]; (Subscript[dΔ, i_->j_,k_])[ℰ_] := ℰ // (Subscript[Δ, i->j,k])//(Subscript[Δ, -i-> -j,-k]);

(Subscript[U, -1])[](Subscript[U, 1])[a](Subscript[U, -2])[b](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

{(Subscript[U, -1])[](Subscript[U, 1])[a](Subscript[U, -2])[y](Subscript[U, 2])[] // (Subscript[dm, 2,1->1]), (Subscript[U, -1])[](Subscript[U, 1])[a](Subscript[U, -2])[y](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])}

(Subscript[U, -1])[](Subscript[U, 1])[A[1]](Subscript[U, -2])[y](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[b](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[B[1]](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[y](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

z=(Subscript[U, -1])[](Subscript[U, 1])[x](Subscript[U, -2])[y](Subscript[U, 2])[](Subscript[U, -3])[b](Subscript[U, 3])[];
(z // (Subscript[dm, 1,2->1]) // (Subscript[dm, 1,3->1]))-(z // (Subscript[dm, 2,3->2])//(Subscript[dm, 1,2->1])) // DUForm

z=(Subscript[U, -1])[b,b,y](Subscript[U, 1])[A[2],x,x](Subscript[U, -2])[B[-1],y,y](Subscript[U, 2])[a](Subscript[U, -3])[b,y](Subscript[U, 3])[a,a,x];
(z // (Subscript[dm, 1,2->1]) // (Subscript[dm, 1,3->1]))-(z // (Subscript[dm, 2,3->2])//(Subscript[dm, 1,2->1])) // DUForm

The R-Matrix

Using Quesne’s formula.

(Subscript[R, i_,j_]) :=𝕆[
(Subscript[U, -i])[y->y,b->b](Subscript[U, i])[](Subscript[U, -j])[](Subscript[U, j])[a->a,x->x],
Series[Exp[ℏ b a+(∑_(k=1)^$TD)(((((1-(E^(ℏ α β))))^k)(((ℏ x y))^k))/(k(1-(E^(k ℏ α β)))))], {ℏ,0,$TD}]
]

$TD=3; (Subscript[R, 1,2])//DUForm

$TD=5; {lhs=(Subscript[R, 1,3])//(Subscript[dΔ, 1->1,2]), rhs=(Subscript[R, 2,3])**(Subscript[R, 1,3]), lhs-rhs} //Last//ExpandAB// DUForm

$TD=5; {lhs=(Subscript[R, 1,2])//(Subscript[dΔ, 2->2,3]), rhs=(Subscript[R, 1,2])**(Subscript[R, 1,3]), lhs-rhs} //Last //ExpandAB// DUForm

$TD=5; Table[
{lhs=(Subscript[R, 1,2])**(Subscript[dΔ, 1->2,1])[f], rhs=(Subscript[dΔ, 1->1,2])[f]**(Subscript[R, 1,2]), lhs-rhs} //Last //ExpandAB// DUForm,
{f, {(Subscript[U, -1])[](Subscript[U, 1])[a], (Subscript[U, -1])[](Subscript[U, 1])[x],(Subscript[U, -1])[b](Subscript[U, 1])[],(Subscript[U, -1])[y](Subscript[U, 1])[]}}]

$TD=5;{lhs=ExpandAB[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])], rhs=ExpandAB[(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])], Coefficient[lhs-rhs, (ℏ^$TD)]} // Last

$TD=5; (Subscript[Si, 2])[(Subscript[R, 1,2])]**(Subscript[R, 1,2]) // ExpandAB // DUForm

Cuaps

Drinfeld element u

(Subscript[u, i_]):=(Subscript[R, 1,2])//(Subscript[S, 2])//(Subscript[m, 2,1->i])

$TD=1;(Subscript[u, 1])//DUForm

$TD=1; Table[
{lhs=f**(Subscript[u, 1]), rhs=(Subscript[u, 1])**(Subscript[S, 1])[(Subscript[S, 1])[f]], lhs-rhs} //Last //ExpandAB// DUForm,
{f, {(Subscript[U, -1])[](Subscript[U, 1])[a], (Subscript[U, -1])[](Subscript[U, 1])[x],(Subscript[U, -1])[b](Subscript[U, 1])[],(Subscript[U, -1])[y](Subscript[U, 1])[]}}]