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

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

UEA` with provisional modification

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

B[0,_]=0; B[_,0]=0;
B[c_*x_,y_]/; MemberQ[$Basis,x]:=Expand[c B[x,y]];
B[y_,c_*x_]/; MemberQ[$Basis,x]:=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_])[1] := (Subscript[U, i])[];
(Subscript[UU, i_])[((x_)^(p_))]:=(Subscript[UU, i])@@Table[x,{p}];
(Subscript[UU, i_])[ℰ_] := ℰ /. {
U[xs__] :> (Subscript[U, i])[xs],
x_ /; MemberQ[$Basis,x]:>(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, s__])[sd_SeriesData] := MapAt[(Subscript[m, s]), sd, {3,All}];
(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_](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[{is=Supp[x]⋂Supp[y],σ,z},
z=x; Do[z=(Subscript[m, i->σ@i])[z], {i,is}];
z=Expand[y z]; Do[z=(Subscript[m, σ@i,i->i])[z], {i,is}]; z];
UB[x_,y_] := USimp[x**y-y**x];

𝕆[specs_,sd_SeriesData] := MapAt[𝕆[specs,#]&, sd, {3,All}];
𝕆[specs_, poly_] := Module[{rules,vars,elems},
rules=Union@@Cases[{specs}, (Subscript[U, _])[u___]:>Cases[{u},r_Rule], ∞];
vars=First/@rules; elems=Last/@rules;
USimp@Total[CoefficientRules[poly, vars] /. (ps_ -> c_) :> c(
specs /. MapThread[((#1->_) :> ((#3)^(#2)))&,{vars,ps,elems}] /. (Subscript[U, i_]):>(Subscript[UU, i])
)]
]

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.

$Basis={g,G,e,h,H,f}; $PBWRule=Thread[$Basis->Range@Length@$Basis];

𝕆[(Subscript[U, 1])[x->g], Normal@Series[(E^(η x)),{η,0,5}]]

B[g,e] = γ e; B[e,G]=((E^(-γ η))-1)U[G,e]; B[g,G]=0;

With[{G=𝕆[(Subscript[U, 1])[x->g], Series[(E^(η x)),{η,0,5}]]}, UB[(Subscript[U, 1])[e],G]-((E^(-γ η))-1)G**(Subscript[U, 1])[e]]

B[e,G]

B[h,f] = -η f; B[f,H]=((E^(γ η))-1)U[H,f]; B[f,H]=0;

With[{H=𝕆[(Subscript[U, 1])[x->h], Series[(E^(γ x)),{γ,0,5}]]}, UB[(Subscript[U, 1])[f],H]-((E^(γ η))-1)H**(Subscript[U, 1])[f]]

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,xs___] :> (USimp[(Subscript[U, j])[G](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])[e,xs___] :> (USimp[((Subscript[U, j])[e](Subscript[U, k])[G]+(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,xs___] :> (USimp[(Subscript[U, j])[H](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])[f,xs___] :> (USimp[((Subscript[U, j])[f](Subscript[U, k])[]+(Subscript[U, j])[H](Subscript[U, k])[f])(Subscript[qΔ, i->tj,tk])[(Subscript[U, i])[xs]]] // (Subscript[m, j,tj->j]) // (Subscript[m, k,tk->k]))
}]

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

The Antipode

S[g]=-g; S[G]=Oops;

The Pairing at Lie-Level and Compatibilities

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]]=γ, P[U[g],U[f]]=0}, {P[U[G],U[h]]=η, P[U[G],U[H]]=(E^(η γ)), 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]]

Factor@{P[U[e,e],U[f,f]], P[U[e,e,e],U[f,f,f]],  P[U[e,e,e,e],U[f,f,f,f]],  P[U[e,e,e,e,e],U[f,f,f,f,f]]}

Simplify@FunctionExpand@Table[QFactorial[n,(E^(γ η))], {n,5}]

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