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.

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

I hope to stick to G=(e^(ℏ ϵ g)) and to H=(e^(ℏ γ h)), where [g,e]=γ e and [h,f]=-ϵ f.
Also, (Subscript[qΔ, 12])(g,G,e,h,H,f) = ((Subscript[g, 1])+(Subscript[g, 2]), (Subscript[G, 1])(Subscript[G, 2]), (Subscript[e, 1])+(Subscript[G, 1])(Subscript[e, 2]), (Subscript[h, 1])+(Subscript[h, 2]), (Subscript[H, 1])(Subscript[H, 2]), (Subscript[f, 1])(Subscript[H, 2])+(Subscript[f, 2])).
Also, (g,e) and (h,f) are dual bases.

AlgebraAtom = g|G[_]|e|h|H[_]|f;
$PBWRule={G[_]->1,g->2,e->3,H[_]->4,h->5,f->6};

B[g,e] = γ e; B[e,G[n_]]=((E^(-n ℏ γ ϵ))-1)U[G[n],e]; B[g,G[_]]=0;
B[h,f] = -ϵ f; B[f,H[n_]]=((E^(n ℏ γ ϵ))-1)U[H[n],f]; B[h,H[_]]=0;

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])[x->g], (E^(ℏ ϵ x))]

USimp@With[{G=𝕆[(Subscript[U, 1])[x->g], (E^(ℏ ϵ x))]}, UB[(Subscript[U, 1])[e],G]-𝕆[(E^(-ℏ γ ϵ))-1]G**(Subscript[U, 1])[e]]

B[e,G[3]]

$TD=6;
USimp@With[{H=𝕆[(Subscript[U, 1])[x->h],(E^(ℏ γ x))]}, UB[(Subscript[U, 1])[f],H]-𝕆[(E^(ℏ γ ϵ))-1]H**(Subscript[U, 1])[f]]

x=(Subscript[U, 1])[g,G[2],e,e,e](Subscript[U, 2])[g,g,e](Subscript[U, 3])[g,g,G[-3],e];
(x // (Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))-(x // (Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

x=(Subscript[U, 1])[h,H[2],f,f,f](Subscript[U, 2])[h,h,f](Subscript[U, 3])[h,h,H[-3],f];
(x // (Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))-(x // (Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

The Co-Product and Co-Associativity

(Subscript[qΔ, i_->j_,k_])[ℰ_] := USimp@Module[{tj,tk}, ℰ /. {
(Subscript[U, i])[] -> (Subscript[U, j])[](Subscript[U, k])[],
(Subscript[U, i])[g,xs___] :> (USimp[((Subscript[U, j])[g](Subscript[U, k])[]+(Subscript[U, j])[](Subscript[U, k])[g])(Subscript[qΔ, i->tj,tk])[(Subscript[U, i])[xs]]] // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k])),
(Subscript[U, i])[G[n_],xs___] :> (USimp[(Subscript[U, j])[G[n]](Subscript[U, k])[G[n]](Subscript[qΔ, i->tj,tk])[(Subscript[U, i])[xs]]] // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k])),
(Subscript[U, i])[e,xs___] :> (USimp[((Subscript[U, j])[e](Subscript[U, k])[G[1]]+(Subscript[U, j])[](Subscript[U, k])[e])(Subscript[qΔ, i->tj,tk])[(Subscript[U, i])[xs]]] // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k])),
(Subscript[U, i])[h,xs___] :> (USimp[((Subscript[U, j])[h](Subscript[U, k])[]+(Subscript[U, j])[](Subscript[U, k])[h])(Subscript[qΔ, i->tj,tk])[(Subscript[U, i])[xs]]] // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k])),
(Subscript[U, i])[H[n_],xs___] :> (USimp[(Subscript[U, j])[H[n]](Subscript[U, k])[H[n]](Subscript[qΔ, i->tj,tk])[(Subscript[U, i])[xs]]] // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k])),
(Subscript[U, i])[f,xs___] :> (USimp[((Subscript[U, j])[f](Subscript[U, k])[]+(Subscript[U, j])[H[1]](Subscript[U, k])[f])(Subscript[qΔ, i->tj,tk])[(Subscript[U, i])[xs]]] // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k]))
}];

(Subscript[qΔ, i_->j_,k_,l__])[ℰ_] := ℰ // (Subscript[qΔ, i->j,k])//(Subscript[qΔ, k->k,l])

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

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

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

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

x=(Subscript[U, 1])[g,G[2],e,e,e](Subscript[U, 2])[g,g,G[-3],e];
(x // (Subscript[m, 1,2->1]) // (Subscript[qΔ, 1->1,2]))-(x//(Subscript[qΔ, 2->3,4])//(Subscript[qΔ, 1->1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))

x=(Subscript[U, 1])[h,H[2],f,f,f](Subscript[U, 2])[h,h,H[-3],f];
(x // (Subscript[m, 1,2->1]) // (Subscript[qΔ, 1->1,2]))-(x//(Subscript[qΔ, 2->3,4])//(Subscript[qΔ, 1->1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))

The Antipode

Why o why this annoyance of left-vs-right?

S[g]=-g; S[G[n_]]:=G[-n]; S[e] = -(E^(ℏ γ ϵ)) U[G[-1],e];
S[h]=-h; S[H[n_]]:=H[-n]; S[f] = -U[H[-1],f];
(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]]]]
]];

{lhs=(Subscript[S, 1])[(Subscript[U, 1])[e]], rhs=-(Subscript[U, 1])[e]**(Subscript[U, 1])[G[-1]], lhs==rhs}

(Subscript[U, 1])[e] // (Subscript[S, 1]) // (Subscript[S, 1])

(Subscript[U, 1])[f] // (Subscript[S, 1]) // (Subscript[S, 1])

(Subscript[S, 1])[(Subscript[U, 1])[g,G[3],e,e]]

(Subscript[U, 1])[g,G[3],e,e] // (Subscript[qΔ, 1->1,2])

(Subscript[U, 1])[g,G[3],e,e] // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 2])

test=(Subscript[U, 1])[g,G[3],e,e];
{test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 1,2->1]), test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 2,1->1]), test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 1,2->1]), test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 2,1->1])}

test=(Subscript[U, 1])[h,H[3],f,f];
{test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 1,2->1]), test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 2]) // (Subscript[m, 2,1->1]), test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 1,2->1]), test // (Subscript[qΔ, 1->1,2]) // (Subscript[S, 1]) // (Subscript[m, 2,1->1])}

x=(Subscript[U, 1])[h,H[2],f,f,f](Subscript[U, 2])[h,h,H[-3],f];
(x//(Subscript[m, 1,2->1])//(Subscript[S, 1]))-(x//(Subscript[S, 1])//(Subscript[S, 2])//(Subscript[m, 2,1->1]))

x=(Subscript[U, 1])[g,G[2],e,e,e](Subscript[U, 2])[g,g,G[-3],e];
(x//(Subscript[m, 1,2->1])//(Subscript[S, 1]))-(x//(Subscript[S, 1])//(Subscript[S, 2])//(Subscript[m, 2,1->1]))

x=(Subscript[U, 1])[];
(x//(Subscript[qΔ, 1->1,2])//(Subscript[S, 1])//(Subscript[m, 1,2->1]))

x=(Subscript[U, 1])[];
(x//(Subscript[qΔ, 1->1,2])//(Subscript[S, 2])//(Subscript[m, 1,2->1]))

x=(Subscript[U, 1])[g,G[2],e,e,e];
(x//(Subscript[qΔ, 1->1,2])//(Subscript[S, 1])//(Subscript[m, 1,2->1]))

x=(Subscript[U, 1])[g,G[2],e,e,e];
(x//(Subscript[qΔ, 1->1,2])//(Subscript[S, 2])//(Subscript[m, 1,2->1]))

x=(Subscript[U, 1])[h,H[2],f,f,f];
(x//(Subscript[qΔ, 1->1,2])//(Subscript[S, 1])//(Subscript[m, 1,2->1]))

x=(Subscript[U, 1])[h,H[2],f,f,f];
(x//(Subscript[qΔ, 1->1,2])//(Subscript[S, 2])//(Subscript[m, 1,2->1]))

The Pairing at Lie-Level and Compatibilities

P[U[],U[]] = 1;
P[U[], U[H[_]]] = P[U[G[_]],U[]] = 1;
P[U[], U[__]] = P[U[__],U[]] = 0;
(({{P[U[g],U[h]]=(ℏ^(-1)), P[U[g],U[H[n_]]]=n γ, P[U[g],U[f]]=0}, {P[U[G[n_]],U[h]]=n ϵ, P[U[G[n_]],U[H[m_]]]=(E^(n m ℏ γ ϵ )), P[U[G[_]],U[f]]=0}, {P[U[e],U[h]]=0, P[U[e],U[H[_]]]=0, P[U[e],U[f]]=(ℏ^(-1))}}));

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

t=(Subscript[U, i])[g](Subscript[U, j])[e](Subscript[U, k])[f];
{(Subscript[m, i,j->i])[t]-(Subscript[m, j,i->i])[t], (Subscript[qΔ, k->k,l])[t]-(Subscript[qΔ, k->l,k])[t]}

t=(Subscript[U, i])[g](Subscript[U, j])[e](Subscript[U, k])[f];
{((Subscript[m, i,j->i])[t]-(Subscript[m, j,i->i])[t])//(Subscript[P, i,k]), ((Subscript[qΔ, k->k,l])[t]-(Subscript[qΔ, k->l,k])[t]) // (Subscript[P, i,k])//(Subscript[P, j,l])}

Table[t=(Subscript[U, i])[xi](Subscript[U, j])[xj](Subscript[U, k])[yk];
{((Subscript[m, i,j->i])[t]-(Subscript[m, j,i->i])[t])//(Subscript[P, i,k]), ((Subscript[qΔ, k->k,l])[t]-(Subscript[qΔ, k->l,k])[t]) // (Subscript[P, i,k])//(Subscript[P, j,l])},
{xi,{g,e}}, {xj,{g,e}}, {yk,{h,f}}]

Table[t=(Subscript[U, i])[xi](Subscript[U, k])[yk](Subscript[U, l])[yl];
{((Subscript[qΔ, i->i,j])[t]-(Subscript[qΔ, i->j,i])[t])//(Subscript[P, i,k])//(Subscript[P, j,l]), ((Subscript[m, k,l->k])[t]-(Subscript[m, l,k->k])[t]) // (Subscript[P, i,k])},
{xi,{g,e}}, {yk,{h,f}}, {yl,{h,f}}]

General Pairings

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[U, j])[xs](Subscript[qΔ, 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[qΔ, i->i,j])[(Subscript[U, i])[xs]](Subscript[U, k])[y](Subscript[U, l])[ys]] // (Subscript[P, i,k]) // (Subscript[P, j,l])];

{P[U[g,e],U[h]], P[U[g,e],U[f]], P[U[e,e],U[f]]}

P[U[e],U[f,f]]

P[U[e,e],U[f,f]]

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

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

MapThread[Equal,{lhs,rhs}]

P[U[g,g,g,g,g],U[h,h,h,h,h]]

P[U[g,g,g,g,g,e,e,e,e],U[h,h,h,h,h,f,f,f,f]] // Factor

x=(Subscript[U, 1])[g,G[-3],e,e](Subscript[U, 2])[g,g,G[1],e](Subscript[U, 3])[h,H[2],f,f,f];
(x//(Subscript[m, 1,2->1])//(Subscript[P, 1,3]))-(x//(Subscript[qΔ, 3->3,4])//(Subscript[P, 1,3])//(Subscript[P, 2,4]))

x=(Subscript[U, 1])[h,H[-3],f,f](Subscript[U, 2])[h,h,H[1],f](Subscript[U, 3])[g,G[2],e,e,e];
(x//(Subscript[m, 1,2->1])//(Subscript[P, 3,1]))-(x//(Subscript[qΔ, 3->3,4])//(Subscript[P, 3,1])//(Subscript[P, 4,2]))

x=(Subscript[U, 1])[g,g,G[-3],e,e,e](Subscript[U, 2])[h,h,H[2],f,f,f];
(x//(Subscript[S, 1])//(Subscript[P, 1,2]))-(x//(Subscript[S, 2])//(Subscript[P, 1,2]))

The Double

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

(Subscript[U, -1])[](Subscript[U, 1])[g](Subscript[U, -2])[h](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[g](Subscript[U, -2])[f](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[G[1]](Subscript[U, -2])[f](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[e](Subscript[U, -2])[h](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[e](Subscript[U, -2])[H[1]](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

(Subscript[U, -1])[](Subscript[U, 1])[e](Subscript[U, -2])[f](Subscript[U, 2])[] // (Subscript[dm, 1,2->1])

x=(Subscript[U, -1])[](Subscript[U, 1])[e](Subscript[U, -2])[f](Subscript[U, 2])[](Subscript[U, -3])[h](Subscript[U, 3])[];
(x // (Subscript[dm, 1,2->1]) // (Subscript[dm, 1,3->1]))-(x // (Subscript[dm, 2,3->2])//(Subscript[dm, 1,2->1]))

x=(Subscript[U, -1])[h,h,f](Subscript[U, 1])[G[2],e,e](Subscript[U, -2])[H[-1],f,f](Subscript[U, 2])[g](Subscript[U, -3])[h,f](Subscript[U, 3])[g,g,e];
(x // (Subscript[dm, 1,2->1]) // (Subscript[dm, 1,3->1]))-(x // (Subscript[dm, 2,3->2])//(Subscript[dm, 1,2->1]))

The R-Matrix

Using Quesne’s formula.

(Subscript[R, i_,j_])[d_] := Module[{x,y},𝕆[
(Subscript[U, -i])[(Subscript[x, 1])->h, (Subscript[x, 2])->f](Subscript[U, i])[](Subscript[U, -j])[](Subscript[U, j])[(Subscript[y, 1])->g,(Subscript[y, 2])->e],
Series[Exp[ℏ (Subscript[x, 1])(Subscript[y, 1])+(∑_(k=1)^d)(((((1-(E^(ℏ γ ϵ))))^k)(((ℏ (Subscript[x, 2])(Subscript[y, 2])))^k))/(k(1-(E^(k ℏ γ ϵ)))))], {ℏ,0,d}]
]]

(Subscript[R, 1,2])[1]

$TD=1; ((Subscript[R, 1,2])[1](Subscript[R, 3,4])[1]//(Subscript[S, 4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2])) /. (Subscript[U, -4])[] (Subscript[U, -3])[]->1

$TD=1; (Subscript[S, -1])[(Subscript[R, 1,2])[1]]**(Subscript[R, 1,2])[1]

Import from older versions and upgrade/verify!