(* ::Package:: *)

(************************************************************************)\012(* This file was generated automatically by the Mathematica front end.  *)\012(* It contains Initialization cells from a Notebook file, which         *)\012(* typically will have the same name as this file except ending in      *)\012(* ".nb" instead of ".m".                                               *)\012(*                                                                      *)\012(* This file is intended to be loaded into the Mathematica kernel using *)\012(* the package loading commands Get or Needs.  Doing so is equivalent   *)\012(* to using the Evaluate Initialization Cells menu command in the front *)\012(* end.                                                                 *)\012(*                                                                      *)\012(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)\012(* automatically each time the parent Notebook file is saved in the     *)\012(* Mathematica front end.  Any changes you make to this file will be    *)\012(* overwritten.                                                         *)\012(************************************************************************)\012\012

(* ::Input::Initialization:: *)
SetDirectory@"C:\\drorbn\\AcademicPensieve\\Projects\\SolvablePBW";
<< KnotTheory`


(* ::Input::Initialization:: *)
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@{"**",\[Epsilon],$k,CF,SSQ,NilQ, B, m, SetAlgebra, U, UB, UProducts, USimp, UU, $Basis, $PBWRule,\[Delta],adPower, adExp},
"."];
Begin["`Private`"];


(* ::Input::Initialization:: *)
Subscript[\[Delta], i_,j_]:=If[i==j,1,0];


(* ::Input::Initialization:: *)
SSQ[c_.*x_]/;MemberQ[$Basis,x]:=\[Not]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));


(* ::Input::Initialization:: *)
$k=1;


(* ::Input::Initialization:: *)
CF[\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE]/.E^L_:>E^Expand[L]]/.{\[Epsilon]^k_./;k>$k->0};


(* ::Input::Initialization:: *)
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]];


(* ::Input::Initialization:: *)
x_\[PrecedesEqual]y_:=OrderedQ[{x,y}/.$PBWRule]; x_\[Precedes]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_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. {
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[\[ScriptCapitalE]_]:= Collect[\[ScriptCapitalE], Times[Subscript[U, _][__]..], Expand];
USimp[\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE]];


(* ::Input::Initialization:: *)
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_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. Subscript[U, i]->Subscript[U, j];


(* ::Input::Initialization:: *)
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\[PrecedesEqual]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
];


(* ::Input::Initialization:: *)
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]}];


(* ::Input::Initialization:: *)
Supp[\[ScriptCapitalE]_]:= Union@Cases[{\[ScriptCapitalE]}, Subscript[U, i_][___]:>i, \[Infinity]];


(* ::Input::Initialization:: *)
Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
x_**y_ := Module[{is=Supp[x]\[Intersection]Supp[y],\[Sigma],z},
z=x; Do[z=Subscript[m, i->\[Sigma]@i][z], {i,is}];
z=Expand[y z]; Do[z=Subscript[m, \[Sigma]@i,i->i][z], {i,is}]; z];
UB[x_,y_] := USimp[x**y-y**x];


(* ::Input::Initialization:: *)
End[]; EndPackage[];


(* ::Input::Initialization:: *)
Print["UEA`SetAlgebra knows \"sl2\"."];


(* ::Input::Initialization:: *)
SetAlgebra["sl2"] := (
Print["In sl2: \[LeftAngleBracket]e,h,f\[RightAngleBracket]/([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;
);


(* ::Input::Initialization:: *)
Print["UEA`SetAlgebra knows the \[Epsilon]-nilpotent algebra Subscript[gl, n,\[Epsilon]]."];


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


(* ::Input::Initialization:: *)
SetAlgebra[Subscript[gl, 2,\[Epsilon]]];
$PBWRule
MatrixForm@Table[{b1,b2}->B[b1,b2],{b1,$Basis},{b2,$Basis}]


(* ::Input::Initialization:: *)
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];


(* ::Input::Initialization:: *)
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],{\[Epsilon],0,$k}]] . Table[Coefficient[y,b],{b,$Basis}]]
]


(* ::Input::Initialization:: *)
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
]


(* ::Input::Initialization:: *)
\[Lambda]Tangent[]=0;
\[Lambda]Tangent[xs___,x_]:=adExp[x][\[Lambda]Tangent[xs]]+\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Lambda]\)]x\);
\[Lambda]Tangent[xs_List]:=\[Lambda]Tangent@@xs


(* ::Input::Initialization:: *)
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_]:>\!\(
\*SubscriptBox[\(\[PartialD]\), \(v\)]f\)],fun,iv],{1,2}]
],
{eqns,funs}
];
sol
]



