Pensieve header: The PBW multiplication tensor for  $gl_{n,\epsilon}$ using the full $\lambda$-tangent formalism. Some material from pensieve://Projects/UEA.

SetDirectory@"C:\\drorbn\\AcademicPensieve\\Projects\\SolvablePBW";
<< KnotTheory`

Prolog

BeginPackage["UEA`"];
Print["UEA` does computations in general universal enveloping algebras and PBW algebras. It is in the public domain, available at http://drorbn.net/AcademicPensieve/Projects/SolvablePBW/. Dror Bar-Natan is committed to support it within reason until June 1, 2027. This is version 260601."];
Print["UEA` implements / extends ",
Sort@{"**",ϵ,$k,CF,SSQ,NilQ, B, m, SetAlgebra, U, UB, UProducts, USimp, UU, $Basis, $PBWRule,δ,adPower, adExp},
"."];
Begin["`Private`"];

Utilities

(Subscript[δ, i_,j_]):=If[i==j,1,0];

SSQ[c_.*x_]/;MemberQ[$Basis,x]:=¬NilQ[x];  (* Semi-Simple Q *)
NilQ[c_*x_]/;MemberQ[$Basis,x]:=NilQ[x];
SSQ[x_Plus]:=And@@(SSQ/@(List@@x));
NilQ[x_Plus]:=And@@(NilQ/@(List@@x));

$k=1;

CF[ℰ_]:=Expand[ℰ/.(E^(L_)):>(E^(Expand[L]))]/.{(ϵ^(k_.))/;k>$k->0};

Implementing general universal enveloping algebras

B[0,_]=0; B[_,0]=0;
B[c_*x_,y_]/; MemberQ[$Basis,x]:=CF[c B[x,y]];
B[y_,c_*x_]/; MemberQ[$Basis,x]:=CF[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_] := CF[-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
];

UProducts[{},0]={1}; UProducts[{},d_Integer] /; d>0 = {};
UProducts[{i_,is___}, d_Integer] := Sort@Flatten@Table[((Subscript[U, i])@@@Subsets[$Basis,{j}])u, {j,0,d},{u,UProducts[{is},d-j]}];

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

Epilog

End[]; EndPackage[];

Predefined Algebras

sl(2)

Print["UEA`SetAlgebra knows \"sl2\"."];

SetAlgebra["sl2"] := (
Print["In sl2: ⟨e,h,f⟩/([h,e]=2e, [h,f]=-2f, [e,f]=h)."];
B[h,e]=2e; B[h,f]=-2f; B[e,f]=h;
$Algebra="sl2";
$Basis={e,h,f};
$PBWRule = {e->1,h->2,f->3};
NilQ[e]=NilQ[f]=True; NilQ[h]=False;
);

(Subscript[gl, n,ϵ])

Print["UEA`SetAlgebra knows the ϵ-nilpotent algebra \!(Subscript[gl, n,ϵ])."];

SetAlgebra[(Subscript[gl, n_,ϵ])] := (
$Algebra=(Subscript[gl, n,ϵ]);
$Basis=Flatten@{
Table[(Subscript[y, α,β]),{β,2,n},{α,1,β-1}],
Table[(Subscript[x, α,β]),{β,1,n},{α,1,β}]
};
(*$Basis=Reverse@SortBy[$Basis,If[#[[1]]===x,{0,#[[3]]-#[[2]]}, {1,#[[2]]-#[[3]]}]&];*)
NilQ[(Subscript[y, __])]=True; NilQ[(Subscript[x, α_,β_])]:=(α=!=β); (* Nilpotent Q *)
$PBWRule = Thread[$Basis->Range@Length@$Basis];
B[(Subscript[x, i_,j_]),(Subscript[x, k_,l_])]:=(Subscript[δ, j,k])(Subscript[x, i,l])-(Subscript[δ, l,i])(Subscript[x, k,j]);
B[(Subscript[y, i_,j_]),(Subscript[y, k_,l_])]:=CF[-ϵ (Subscript[δ, j,k])(Subscript[y, i,l])+ϵ (Subscript[δ, l,i])(Subscript[y, k,j])];
B[(Subscript[x, i_,j_]),(Subscript[y, l_,k_])]:=CF[(Subscript[δ, j,k])(Subscript[x, i,l])-(Subscript[δ, l,i])(Subscript[x, k,j])/.(Subscript[x, α_,β_]):>If[α<=β,ϵ (Subscript[x, α,β]),(Subscript[y, β,α])]];
);

SetAlgebra[(Subscript[gl, 2,ϵ])];
$PBWRule
MatrixForm@Table[{b1,b2}->B[b1,b2],{b1,$Basis},{b2,$Basis}]

adPower[x_,k_,Env_][c_*y_]/; MemberQ[$Basis,y]:=CF[c adPower[x,k,Env][y]];
adPower[x_,k_,Env_][y_Plus] := adPower[x,k,Env]/@ y;
adPower[_,0,Env_][y_]:=y;
adPower[x_,k_,Env_][0]=0;
adPower[x_,k_,Env_][y_]/;MemberQ[$Basis,y]:=adPower[x,k,Env][y]=B[adPower[x,k-1,Env][y],x];
adPower[x_,k_][y_]:=adPower[x,k,{$Algebra,$k}][y];

x0=($Basis/.{x->ξ0,y->η0}).$Basis
x1=($Basis/.{x->ξ1,y->η1}).$Basis

adExp[x_][y_]/;SSQ[x]:=Expand@Module[{A,b,c},
A=Table[Coefficient[B[b,x],c],{c,$Basis},{b,$Basis}];
CF[$Basis.Normal[Series[MatrixExp[A],{ϵ,0,$k}]].Table[Coefficient[y,b],{b,$Basis}]]
]

SSQ[(Subscript[ξ0, 1,1]) (Subscript[x, 1,1])]

adExp[(Subscript[ξ0, 1,1]) (Subscript[x, 1,1])][x1]

adExp[x_][y_]/;NilQ[x]:=Expand@Module[{k=0,s=0},
While[adPower[x,k][y]=!=0,
s+=adPower[x,k][y]/k!;
++k
];
s
]

adExp[(Subscript[ξ0, 1,2]) (Subscript[x, 1,2])][x1]

λTangent[]=0;
λTangent[xs___,x_]:=adExp[x][λTangent[xs]]+(∂_λ)x;
λTangent[xs_List]:=λTangent@@xs

$Basis($Basis/.{x->ξ,y->η})

λTangent@(λ $Basis($Basis/.{x->ξ,y->η}))

$Basis

lhs=λTangent[
Join[λ $Basis($Basis/.{x->ξ1,y->η1}),λ $Basis($Basis/.{x->ξ2,y->η2})]
]

rhs=λTangent@($Basis($Basis/.{(Subscript[x, α_,α_]):>CF[(Subscript[f, α,α])[λ]],(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]}))

SSBasis=Select[$Basis,SSQ]

eqns=Simplify[(Coefficient[lhs-rhs,#]==0)&/@$Basis]

Length@eqns

unknowns=$Basis/.{(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]}

$Basis/.{(Subscript[x, αβ__]):>(Subscript[f, αβ])[0]==0,(Subscript[y, αβ__]):>(Subscript[g, αβ])[0]==0}

{sol0}=Block[{$k=0},Simplify@DSolve[
lhs=λTangent[
Join[λ $Basis($Basis/.{x->ξ1,y->η1}),λ $Basis($Basis/.{x->ξ2,y->η2})]
];
rhs=λTangent@($Basis($Basis/.{(Subscript[x, α_,α_]):>CF[(Subscript[f, α,α])[λ]],(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]}));
Join[
(Coefficient[CF[lhs-rhs],#]==0)&/@$Basis,
$Basis/.{(Subscript[x, αβ__]):>(Subscript[f, αβ])[0]==0,(Subscript[y, αβ__]):>(Subscript[g, αβ])[0]==0}
],
$Basis/.{(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]},
λ
]]

{sol1}=Block[{$k=1},Simplify@DSolve[
lhs=λTangent[
Join[λ $Basis($Basis/.{x->ξ1,y->η1}),λ $Basis($Basis/.{x->ξ2,y->η2})]
];
rhs=λTangent[
$Basis($Basis/.{(Subscript[x, α_,α_]):>CF[(Subscript[f, α,α])[λ]],(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]})/.(sol0/.((a_->b_):>(a->ϵ a+b)))
];
Join[
(Coefficient[CF[lhs-rhs],#]==0)&/@$Basis,
$Basis/.{(Subscript[x, αβ__]):>(Subscript[f, αβ])[0]==0,(Subscript[y, αβ__]):>(Subscript[g, αβ])[0]==0}
],
$Basis/.{(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]},
λ
]]

TriangularDSolve[eqns_,funs_,iv_]:=Module[{sol={},e,fun,der},
MapThread[
{e,fun}|->sol=Echo@Join[sol,
MapAt[CF,First@DSolve[Echo@CF[e/.Derivative[1][f_][v_]:>der[f[v],v]/.sol/.der[f_,v_]:>(∂_v)f],fun,iv],{1,2}]
],
{eqns,funs}
];
sol
]

SetAlgebra[(Subscript[gl, 3,ϵ])];
$k=1
$PBWRule
MatrixForm@Table[{b1,b2}->B[b1,b2],{b1,$Basis},{b2,$Basis}]

DeleteCases[Flatten[Table[{a,b,c}->B[a,B[b,c]]+B[b,B[c,a]]+B[c,B[a,b]],{a,$Basis},{b,$Basis},{c,$Basis}]], _->0]

$k=0;
{sol0}=Simplify@DSolve[
lhs=λTangent[
Join[λ $Basis($Basis/.{x->ξ1,y->η1}),λ $Basis($Basis/.{x->ξ2,y->η2})]
];
rhs=λTangent@($Basis($Basis/.{(Subscript[x, α_,α_]):>CF[(Subscript[f, α,α])[λ]],(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]}));
Join[
(Coefficient[CF[lhs-rhs],#]==0)&/@$Basis,
$Basis/.{(Subscript[x, αβ__]):>(Subscript[f, αβ])[0]==0,(Subscript[y, αβ__]):>(Subscript[g, αβ])[0]==0}
],
$Basis/.{(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]},
λ
]

$k=1;SBasis=SortBy[$Basis,If[#[[1]]===x,{0,#[[3]]-#[[2]]}, {1,#[[2]]-#[[3]]}]&];
lhs=λTangent[
Join[λ $Basis($Basis/.{x->ξ1,y->η1}),λ $Basis($Basis/.{x->ξ2,y->η2})]
];
rhs=λTangent[
$Basis($Basis/.{(Subscript[x, α_,α_]):>CF[(Subscript[f, α,α])[λ]],(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]})/.(sol0/.((a_->b_):>(a->ϵ a+b)))
];
eqns=Transpose@{
(Coefficient[CF[lhs-rhs],#]==0)&/@SBasis,
SBasis/.{(Subscript[x, αβ__]):>(Subscript[f, αβ])[0]==0,(Subscript[y, αβ__]):>(Subscript[g, αβ])[0]==0}
};
unknowns=SBasis/.{(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]};
(*{sol1}=DSolve[Flatten@eqns,unknowns,λ]*)
sol1=TriangularDSolve[eqns,unknowns,λ]

SetAlgebra[(Subscript[gl, 3,ϵ])];
$k=1
$PBWRule
MatrixForm@Table[{b1,b2}->B[b1,b2],{b1,$Basis},{b2,$Basis}]

$Basis

SortBy[$Basis,If[#[[1]]===x,{0,#[[3]]-#[[2]]}, {1,#[[2]]-#[[3]]}]&]

SBasis=SortBy[$Basis,If[#[[1]]===x,{0,#[[3]]-#[[2]]}, {1,#[[2]]-#[[3]]}]&];
sol[-1]=0SBasis;
Do[
Block[{$k=k},
s0=Thread[SBasis->sol[k-1]];
lhs=λTangent[
Join[λ $Basis($Basis/.{x->ξ1,y->η1}),λ $Basis($Basis/.{x->ξ2,y->η2})]
];
rhs=λTangent[
$Basis($Basis/.{(Subscript[x, αβ__]):>((Subscript[x, αβ])/.s0)+(ϵ^k)(Subscript[f, αβ])[λ], (Subscript[y, αβ__]):>((Subscript[y, αβ])/.s0)+(ϵ^k)(Subscript[g, αβ])[λ]})
];
Echo@"computed lhs and rhs";
eqns=EchoLabel["eqns"]@Transpose@{
(Coefficient[CF[lhs-rhs],#]==0)&/@SBasis,
SBasis/.{(Subscript[x, αβ__]):>(Subscript[f, αβ])[0]==0,(Subscript[y, αβ__]):>(Subscript[g, αβ])[0]==0}
};
unknowns=SBasis/.{(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]};
s=TriangularDSolve[eqns,unknowns,λ];
sol[k]=CF@Together[sol[k-1]+(ϵ^k)(SBasis/.{(Subscript[x, αβ__])->(Subscript[f, αβ])[λ],(Subscript[y, αβ__])->(Subscript[g, αβ])[λ]}/.s)]
],
{k,0,$k}
];
sol[$k].SBasis

osol=(Subscript[𝔼, {i,j}->{k}])[(Subscript[y, 1,2])[k] (Subscript[η, 1,2])[i]+(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j]+(Subscript[y, 1,3])[k] (Subscript[η, 1,3])[i]+(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,3])[j]+(Subscript[y, 2,3])[k] (Subscript[η, 2,3])[i]+(E^(-(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (Subscript[η, 2,3])[j]+(Subscript[x, 1,1])[k] (Subscript[ξ, 1,1])[i]+(Subscript[x, 1,1])[k] (Subscript[ξ, 1,1])[j]+(E^(-(Subscript[ξ, 1,1])[j])) (Subscript[x, 1,2])[k] (Subscript[ξ, 1,2])[i]-(E^((Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i]+(E^(-(Subscript[ξ, 2,2])[i])) (Subscript[x, 1,2])[k] (Subscript[ξ, 1,2])[j]+(E^(-(Subscript[ξ, 1,1])[j])) (Subscript[x, 1,3])[k] (Subscript[ξ, 1,3])[i]+(E^(-(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,3])[k] (Subscript[ξ, 1,3])[j]+(Subscript[x, 2,2])[k] (Subscript[ξ, 2,2])[i]+(Subscript[x, 2,2])[k] (Subscript[ξ, 2,2])[j]+(E^(-(Subscript[ξ, 2,2])[j])) (Subscript[x, 2,3])[k] (Subscript[ξ, 2,3])[i]+(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 2,3])[i]-(Subscript[x, 1,3])[k] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 2,3])[i]+(E^(-(Subscript[ξ, 3,3])[i])) (Subscript[x, 2,3])[k] (Subscript[ξ, 2,3])[j]+(Subscript[x, 3,3])[k] (Subscript[ξ, 3,3])[i]+(Subscript[x, 3,3])[k] (Subscript[ξ, 3,3])[j],-(E^(-(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,2])[i] (Subscript[η, 2,3])[j]+(E^((Subscript[ξ, 2,2])[i])) (Subscript[x, 1,1])[k] (Subscript[η, 1,2])[j] (Subscript[ξ, 1,2])[i]-(E^((Subscript[ξ, 2,2])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 1,2])[j] (Subscript[ξ, 1,2])[i]-(E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,2])[j])^2) (Subscript[ξ, 1,2])[i]+(E^((Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,2])[i] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i]+(Subscript[x, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,2])[j]-(E^(-(Subscript[ξ, 2,2])[j])) (Subscript[x, 2,3])[k] (Subscript[η, 1,2])[j] (Subscript[ξ, 1,3])[i]+(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,3])[i]-(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 3,3])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,3])[i]-(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,3])[i]-(E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,3])[i]+(E^(-(Subscript[ξ, 1,1])[j]-(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i]-(E^(-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i]-(E^(-(Subscript[ξ, 1,1])[j]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i]+(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i]+(Subscript[x, 1,3])[k] (Subscript[η, 1,2])[j] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 1,3])[i]+(Subscript[x, 1,3])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 1,3])[j]+(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 2,3])[j] (Subscript[ξ, 2,3])[i]-(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 3,3])[k] (Subscript[η, 2,3])[j] (Subscript[ξ, 2,3])[i]+(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 2,3])[i]-(E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 2,3])[i]-(E^(-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (((Subscript[η, 2,3])[j])^2) (Subscript[ξ, 2,3])[i]+(E^((Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]-(E^((Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]-2 (E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]+(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]-(E^(-(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 2,3])[i]+(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 2,3])[i]-(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+(Subscript[x, 1,3])[k] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[j] (Subscript[ξ, 2,3])[i]-(E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (((Subscript[ξ, 2,3])[i])^2)+(Subscript[x, 2,3])[k] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[j]+(Subscript[x, 2,3])[k] (Subscript[η, 2,3])[j] (Subscript[ξ, 2,3])[i] (Subscript[ξ, 2,3])[j],-(1/2) (E^(2 (Subscript[ξ, 2,2])[i])) (Subscript[x, 1,1])[k] (((Subscript[η, 1,2])[j])^2) (((Subscript[ξ, 1,2])[i])^2)+(1/2) (E^(2 (Subscript[ξ, 2,2])[i])) (Subscript[x, 2,2])[k] (((Subscript[η, 1,2])[j])^2) (((Subscript[ξ, 1,2])[i])^2)+(E^(-(Subscript[ξ, 1,1])[i]+3 (Subscript[ξ, 2,2])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,2])[j])^3) (((Subscript[ξ, 1,2])[i])^2)+(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (Subscript[η, 1,2])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i]-(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i]-(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,2])[j])^2) (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i]+(E^(-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,2])[i] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i]-(E^((Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i]+(E^((Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i]+2 (E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,2])[j])^2) (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i]-(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,2])[i] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i]+(E^(-(Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 1,3])[i]-(E^((Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 1,3])[i]-(1/2) (E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (((Subscript[η, 1,3])[j])^2) (((Subscript[ξ, 1,3])[i])^2)+(1/2) (E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 3,3])[k] (((Subscript[η, 1,3])[j])^2) (((Subscript[ξ, 1,3])[i])^2)+(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (((Subscript[η, 1,3])[j])^2) (((Subscript[ξ, 1,3])[i])^2)+(E^(-(Subscript[ξ, 1,1])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (((Subscript[η, 1,3])[j])^3) (((Subscript[ξ, 1,3])[i])^2)-(E^(-(Subscript[ξ, 1,1])[j]-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (((Subscript[ξ, 1,3])[i])^2)+(E^(-(Subscript[ξ, 2,2])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[η, 2,3])[j] (((Subscript[ξ, 1,3])[i])^2)+(E^(-(Subscript[ξ, 1,1])[j]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (((Subscript[ξ, 1,3])[i])^2)-(E^(3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (((Subscript[η, 1,3])[j])^3) (Subscript[ξ, 1,2])[i] (((Subscript[ξ, 1,3])[i])^2)+(E^(-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,2])[i] (((Subscript[η, 2,3])[j])^2) (Subscript[ξ, 2,3])[i]+(E^((Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (Subscript[η, 1,2])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]-(E^((Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]-2 (E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,2])[j])^2) (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]-(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,2])[i] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 2,3])[i]-(E^(2 (Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (((Subscript[ξ, 1,2])[i])^2) (Subscript[ξ, 2,3])[i]+(E^(2 (Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (((Subscript[ξ, 1,2])[i])^2) (Subscript[ξ, 2,3])[i]+3 (E^(-(Subscript[ξ, 1,1])[i]+3 (Subscript[ξ, 2,2])[i]+(Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,2])[j])^2) (Subscript[η, 1,3])[j] (((Subscript[ξ, 1,2])[i])^2) (Subscript[ξ, 2,3])[i]-(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 3,3])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]-2 (E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+2 (E^(-(Subscript[ξ, 1,1])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[η, 2,3])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]-(E^(-(Subscript[ξ, 1,1])[j]-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (((Subscript[η, 2,3])[j])^2) (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+2 (E^(-(Subscript[ξ, 2,2])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (Subscript[η, 1,3])[j] (((Subscript[η, 2,3])[j])^2) (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]-(E^((Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+(E^((Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+4 (E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+(E^(-(Subscript[ξ, 1,1])[j]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]-2 (E^(3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+(E^(-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]-(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (((Subscript[η, 1,3])[j])^2) (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,2])[j] (Subscript[ξ, 1,3])[i] (Subscript[ξ, 2,3])[i]+(E^(-(Subscript[ξ, 1,1])[i]+(Subscript[ξ, 2,2])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,3])[j])^3) (((Subscript[ξ, 1,3])[i])^2) (Subscript[ξ, 2,3])[i]-(1/2) (E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (((Subscript[η, 2,3])[j])^2) (((Subscript[ξ, 2,3])[i])^2)+(1/2) (E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 3,3])[k] (((Subscript[η, 2,3])[j])^2) (((Subscript[ξ, 2,3])[i])^2)+(E^(-(Subscript[ξ, 1,1])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,3])[k] (Subscript[η, 1,3])[j] (((Subscript[η, 2,3])[j])^2) (((Subscript[ξ, 2,3])[i])^2)+(E^(-(Subscript[ξ, 2,2])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (((Subscript[η, 2,3])[j])^3) (((Subscript[ξ, 2,3])[i])^2)-2 (E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (((Subscript[ξ, 2,3])[i])^2)-(E^(3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 2,3])[k] (Subscript[η, 1,3])[j] (((Subscript[η, 2,3])[j])^2) (Subscript[ξ, 1,2])[i] (((Subscript[ξ, 2,3])[i])^2)-(1/2) (E^(2 (Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,1])[k] (((Subscript[η, 1,3])[j])^2) (((Subscript[ξ, 1,2])[i])^2) (((Subscript[ξ, 2,3])[i])^2)+(1/2) (E^(2 (Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 2,2])[k] (((Subscript[η, 1,3])[j])^2) (((Subscript[ξ, 1,2])[i])^2) (((Subscript[ξ, 2,3])[i])^2)+3 (E^(-(Subscript[ξ, 1,1])[i]+3 (Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (Subscript[η, 1,2])[j] (((Subscript[η, 1,3])[j])^2) (((Subscript[ξ, 1,2])[i])^2) (((Subscript[ξ, 2,3])[i])^2)+(E^(-(Subscript[ξ, 2,2])[i]+2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (((Subscript[η, 2,3])[j])^2) (Subscript[ξ, 1,2])[j] (((Subscript[ξ, 2,3])[i])^2)-(E^(2 (Subscript[ξ, 3,3])[i])) (Subscript[x, 1,2])[k] (Subscript[η, 1,3])[j] (Subscript[η, 2,3])[j] (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,2])[j] (((Subscript[ξ, 2,3])[i])^2)+2 (E^(-(Subscript[ξ, 1,1])[i]+2 (Subscript[ξ, 2,2])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,3])[j])^3) (Subscript[ξ, 1,2])[i] (Subscript[ξ, 1,3])[i] (((Subscript[ξ, 2,3])[i])^2)+(E^(-(Subscript[ξ, 1,1])[i]+3 (Subscript[ξ, 2,2])[i]+3 (Subscript[ξ, 3,3])[i])) (Subscript[y, 1,2])[k] (((Subscript[η, 1,3])[j])^3) (((Subscript[ξ, 1,2])[i])^2) (((Subscript[ξ, 2,3])[i])^3)];
osol=(List@@osol).Table[(ϵ^k),{k,0,Length[osol]-1}]

CF[(Expand@sol[$k].$Basis/.{(Subscript[ξ1, αβ__]):>(Subscript[ξ, αβ])[i],(Subscript[η1, αβ__]):>(Subscript[η, αβ])[i],(Subscript[ξ2, αβ__]):>(Subscript[ξ, αβ])[j],(Subscript[η2, αβ__]):>(Subscript[η, αβ])[j],λ->1})-(osol/.v_[k]:>v)]