(* ::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:: *)
$p=2; $k=1; $U=QU; $E:={$k,$p};
$trim:={\[HBar]^p_./;p>$p->0, \[Epsilon]^k_./;k>$k->0};
SetAttributes[{SS,SST},HoldAll];
Subscript[q, \[HBar]_]:=E^(\[Epsilon] \[HBar]);
SS[\[ScriptCapitalE]_,op_]:=Collect[Normal@Series[\[ScriptCapitalE],{\[HBar],0,$p}],\[HBar],op];
SS[\[ScriptCapitalE]_]:=SS[\[ScriptCapitalE],Together];
Simp[\[ScriptCapitalE]_,op_]:=Collect[\[ScriptCapitalE],_CU|_QU,op];
Simp[\[ScriptCapitalE]_]:=Simp[\[ScriptCapitalE],SS[#,Expand]&];
SimpT[\[ScriptCapitalE]_]:=Collect[\[ScriptCapitalE],_CU|_QU,SST[#,Expand]&];
K\[Delta]/:Subscript[K\[Delta], i_,j_]:=If[i===j,1,0];
Subscript[c_Integer, k_Integer] := c+O[\[Epsilon]]^(k+1);


(* ::Input::Initialization:: *)
Unprotect[NonCommutativeMultiply]; Attributes[NonCommutativeMultiply]={};
(NCM=NonCommutativeMultiply)[x_] := x;
NCM[x_,y_,z__] := (x**y)**z;
0**_=_**0=0;
(x_Plus)**y_:=(#**y)&/@x; x_**(y_Plus):=(x**#)&/@y;
B[x_,x_]=0; B[x_,y_] := x**y-y**x;
B[x_,y_,e_]:=B[x,y,e]=B[x,y];


(* ::Input::Initialization:: *)
DeclareAlgebra[U_Symbol, opts__Rule] := Module[
{gp,sr,g,cp,M,pow,k=0,
gs=Generators /. {opts},
cs=Centrals /. {opts} /. Centrals -> {}
},
U[Generators]=gs;
(Subscript[#, U]=U@#)&/@gs;
gp=Alternatives@@gs; gp=gp|\!\(\*UnderscriptBox[\(gp\), \(i_\)]\);(* gens *)
sr=Flatten@Table[{g->++k, \!\(\*UnderscriptBox[\(g\), \(i_\)]\)->{i,k}},{g,gs}]; (* sorting \[Rule] *) 
cp=Alternatives@@cs; (* cents *)
SetAttributes[M,HoldRest]; M[0,_]=0; M[a_,x_]:=a x;
CE[\[ScriptCapitalE]_]:=Collect[\[ScriptCapitalE],_U,Expand]/.E^x_:>E^Expand[x]/.$trim;
\!\(\*UnderscriptBox[\(U\), \(i_\)]\)[\[ScriptCapitalE]_]:=\[ScriptCapitalE]/.{t:cp:>\!\(\*UnderscriptBox[\(t\), \(i\)]\),u_U:>(\!\(\*UnderscriptBox[\(#\), \(i\)]\)&)/@u};
\!\(\*UnderscriptBox[\(U\), \(i_\)]\)[NCM[]]=pow[\[ScriptCapitalE]_,0]=U@{}=Subscript[1, U]=U[];
B[U@\!\(\*UnderscriptBox[\((x_)\), \(i_\)]\),U@\!\(\*UnderscriptBox[\((y_)\), \(i_\)]\)]:=\!\(\*UnderscriptBox[\(U\), \(i\)]\)@B[U@x,U@y];
B[U@\!\(\*UnderscriptBox[\((x_)\), \(i_\)]\),U@\!\(\*UnderscriptBox[\((y_)\), \(j_\)]\)] /; i=!=j := 0;
B[U@y_,U@x_]:=CE[-B[U@x,U@y]];
x_**(c_. Subscript[1, U]):=CE[c x]; (c_. Subscript[1, U])**x_:=CE[c x];
(a_. U[xx___,x_])**(b_. U[y_,yy___]) :=If[OrderedQ[{x,y}/.sr],
CE@M[a b/.$trim,U[xx,x,y,yy]],
U@xx**CE@M[a b/.$trim,U@y**U@x+B[U@x,U@y,$E]]**U@yy ];
U@{c_.*(l:gp)^n_,r___}/;FreeQ[c, gp]:= CE[c U@Table[l,{n}]**U@{r}];
U@{c_.*l:gp,r___} := CE[c U[l]**U@{r}];
U@{c_,r___}/;FreeQ[c, gp]:= CE[c U@{r}];
U@{l_Plus, r___} := CE[U@{#,r}& /@ l];
U@{l_,r___} := U@{Expand[l],r};
U[\[ScriptCapitalE]_NonCommutativeMultiply]:=U/@\[ScriptCapitalE];
Subscript[\[DoubleStruckCapitalO], U][specs___,poly_] := Module[{sp,null,vs,us},
sp=Replace[{specs}, l_List:>\!\(\*UnderscriptBox[\(l\), \(null\)]\), {1}];
vs=Join@@(First /@ sp);
us=Join@@(sp /. \!\(\*UnderscriptBox[\(l_\), \(s_\)]\) :> (l/.\!\(\*UnderscriptBox[\(x_\), \(i_\)]\):>\!\(\*UnderscriptBox[\(x\), \(s\)]\)));
CE[Total[
CoefficientRules[poly, vs] /. (p_->c_) :> c U@(us^p)
]] /. \!\(\*UnderscriptBox[\(x_\), \(null\)]\):>x];
Subscript[\[DoubleStruckCapitalO], U][specs___,\[DoubleStruckCapitalE][L_,Q_,P_]]:=Subscript[\[DoubleStruckCapitalO], U][specs,SS@Normal[P E^(L+Q)]];
pow[\[ScriptCapitalE]_,n_]:=pow[\[ScriptCapitalE],n-1]**\[ScriptCapitalE];
Subscript[\[DoubleStruckCapitalS], U][\[ScriptCapitalE]_,ss___Rule] := CE@Total[
CoefficientRules[\[ScriptCapitalE],First/@{ss}]/.(p_->c_):>c NCM@@MapThread[pow,{Last/@{ss},p}]];
Subscript[\[Sigma], rs___][c_.*u_U] := (c/.\!\(\*UnderscriptBox[\((t : cp)\), \(j_\)]\):>\!\(\*UnderscriptBox[\(t\), \(j /. {rs}\)]\))U[List@@(u/.\!\(\*UnderscriptBox[\(v_\), \(j_\)]\):>\!\(\*UnderscriptBox[\(v\), \(j /. {rs}\)]\))];
Subscript[m, j_->k_][c_.*u_U] := CE[((c/.\!\(\*UnderscriptBox[\((t : cp)\), \(j\)]\)->\!\(\*UnderscriptBox[\(t\), \(k\)]\))DeleteCases[u,\!\(\*UnderscriptBox[\(_\), \(j | k\)]\)])**U@@Cases[u,\!\(\*UnderscriptBox[\(w_\), \(j\)]\):>\!\(\*UnderscriptBox[\(w\), \(k\)]\)]**U@@Cases[u,\!\(\*UnderscriptBox[\(_\), \(k\)]\)]];
U /: c_.*u_U*v_U := CE[c u**v];
Subscript[S, i_][c_.*u_U]:= CE[((c/.Subscript[S, i][U,Centrals])DeleteCases[u,\!\(\*UnderscriptBox[\(_\), \(i\)]\)])**\!\(\*UnderscriptBox[\(U\), \(i\)]\)[NCM@@Reverse@Cases[u,\!\(\*UnderscriptBox[\(x_\), \(i\)]\):>S@U@x]]];
Subscript[\[CapitalDelta], i_->j_,k_][c_.*u_U]:= CE[((c/.Subscript[\[CapitalDelta], i->j,k][U,Centrals])DeleteCases[u,\!\(\*UnderscriptBox[\(_\), \(i\)]\)])**(NCM@@Cases[u,\!\(\*UnderscriptBox[\(x_\), \(i\)]\):>Subscript[\[Sigma], 1->j,2->k]@\[CapitalDelta]@U@x] /. NCM[]->U[])]; ]


(* ::Input::Initialization:: *)
$n=3;
DeclareAlgebra[QU,
Generators -> Flatten@{
Table[Subscript[x, i,j],{i,1,$n},{j,i+1,$n+1}],
Table[Subscript[y, i,j],{i,1,$n},{j,i+1,$n+1}],
Table[{Subscript[v, i],Subscript[w, i]},{i,$n}]
},
Centrals -> {}
];


(* ::Input::Initialization:: *)
Ringel[i_,j_]:=Which[
i+1<j\[Or]i>j,0,
i+1==j, -1,
i==j,1
]


(* ::Input::Initialization:: *)
Do[
B[QU@Subscript[v, i],QU@Subscript[v, j]]=B[QU@Subscript[v, i],QU@Subscript[w, j]]=B[QU@Subscript[w, i],QU@Subscript[w, j]]=0;
B[QU@Subscript[v, i],QU@Subscript[x, j,j+1]]=\[HBar](Ringel[j,i]r-Ringel[i,j]s)QU[Subscript[x, j,j+1],Subscript[v, i]];
B[QU@Subscript[v, i],QU@Subscript[y, j,j+1]]=\[HBar](-Ringel[j,i]r+Ringel[i,j]s)QU[Subscript[y, j,j+1],Subscript[v, i]];
B[QU@Subscript[w, i],QU@Subscript[x, j,j+1]]=\[HBar](-Ringel[i,j]r+Ringel[j,i]s)QU[Subscript[x, j,j+1],Subscript[w, i]];
B[QU@Subscript[w, i],QU@Subscript[y, j,j+1]]=\[HBar](Ringel[i,j]r-Ringel[j,i]s)QU[Subscript[y, j,j+1],Subscript[w, i]];
B[QU@Subscript[x, i,i+1],QU@Subscript[y, j,j+1]]=Subscript[K\[Delta], i,j]Subscript[\[DoubleStruckCapitalO], QU][{Subscript[v, i],Subscript[w, i]},SS[(E^(\[HBar] Subscript[v, i])-E^(\[HBar] Subscript[w, i]))/(E^(\[HBar] r)-E^(\[HBar] s))]],
{i,1,$n},{j,1,$n}
];



