(* ::Package:: *)

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



DQ[is___] := (Sort[{is}]===Union[{is}]);
OQ[is___] := OrderedQ[{is}];


Simp[expr_] := Simplify[expr];
S[\[Beta][f_]] := \[Beta][Simp[f]];
S[a[i_,j_]] := a[i,j];
S[a[f_, i_,j_]] := a[Simp[f], i,j];
S[c[f_, k_]] := c[Simp[f], k];
S[\[Delta]a[f_, i_,j_]] := \[Delta]a[Simp[f], i,j];
S[ca[f_, j_,k_,l_]] := ca[Simp[f], j,k,l];
S[\[Delta]aa[f_, i_,j_,k_,l_]] := \[Delta]aa[Simp[f], i,j,k,l];
S[expr_] := expr /. (\[Lambda]_\[Beta]|\[Lambda]_a|\[Lambda]_\[Delta]a|\[Lambda]_c|\[Lambda]_ca|\[Lambda]_\[Delta]aa) :> S[\[Lambda]];


\[Beta][0] :=0;
\[Beta] /: \[Beta][f_] + \[Beta][g_] := \[Beta][f+g] // S;
\[Beta] /: g_*\[Beta][f_] := \[Beta][g f] // S;
a[0,_,_] := 0;
a /: a[f_,j_,k_] + a[g_, j_,k_] := a[f+g, j,k] // S;
a /: g_*a[f_, j_,k_] := a[g f, j,k] // S;
c[0,_] :=0;
c /: c[f_,j_] + c[g_, j_] := c[f+g, j] // S;
c/: g_*c[f_, j_] := c[g f, j] // S;
\[Delta]a[0,_,_] := 0;
\[Delta]a /: \[Delta]a[f_,j_,k_] + \[Delta]a[g_, j_,k_] := \[Delta]a[f+g, j,k] // S;
\[Delta]a /: g_*\[Delta]a[f_, j_,k_] := \[Delta]a[g f, j,k] // S;
ca[0,_,_,_] :=0;
ca /: ca[f_,j_,k_,l_] + ca[g_, j_,k_,l_] := ca[f+g, j,k,l] // S;
ca /: g_*ca[f_, j_,k_,l_] := ca[g f, j,k,l] // S;
\[Delta]aa[0, _,_,_,_] :=0;
\[Delta]aa /: \[Delta]aa[f_,i_,j_,k_,l_] + \[Delta]aa[g_, i_,j_,k_,l_] := \[Delta]aa[f+g, i,j,k,l] // S;
\[Delta]aa /: g_*\[Delta]aa[f_, i_,j_,k_,l_] := \[Delta]aa[g f, i,j,k,l] // S;


VS=False;


S[\[Delta]aa[f_,i_,j_,k_,l_]] /; DQ[i,j,k,l]\[And]OQ[i,k]\[And]!OQ[j,l] := (
If[VS, Print["Standard swinging on ", \[Delta]aa[f,i,j,k,l]]];
S[\[Delta]aa[f,i,l,k,j]+ca[Subscript[b, k]f,l,i,j]-ca[Subscript[b, i]f,l,k,j]-ca[Subscript[b, k]f,j,i,l]+ca[Subscript[b, i]f,j,k,l]]
);


S[\[Delta]aa[f_,i_,j_,k_,l_]] /; ({i,j}\[Intersection]{k,l}==={})\[And]!OQ[i,k] := (
If[VS, Print["Locality on ", \[Delta]aa[f,i,j,k,l]]];
\[Delta]aa[f,k,l,i,j] // S
);


S[\[Delta]aa[f_,i_,k_,j_,k_]] /; DQ[i,j,k]\[And]!OQ[i,j] := (
If[VS, Print["Commute heads on ", \[Delta]aa[f,i,k,j,k]]];
S[\[Delta]aa[f,j,k,i,k] + \[Delta]a[-Subscript[b, i]f,j,k]+\[Delta]a[Subscript[b, j]f,i,k]]
);


S[\[Delta]aa[f_,i_,j_,k_,i_]] /; DQ[i,j,k]\[And]!OQ[i,k] := (
If[VS, Print["Commute head/tail on ", \[Delta]aa[f,i,j,k,i]]];
S[
\[Delta]aa[f,k,i,i,j]+\[Delta]aa[f,k,j,i,j]-\[Delta]aa[f,i,j,k,j]
]
);


S[\[Delta]aa[f_,k_,j_,j_,i_]] /; DQ[i,j,k]\[And]OQ[i,j,k] := (
If[VS, Print["Commute head/tail on ", \[Delta]aa[f,k,j,j,i]]];
S[
\[Delta]aa[f,j,i,k,j]+\[Delta]aa[f,j,i,k,i]-\[Delta]aa[f,k,i,j,i]
]
);


S[\[Delta]aa[f_,j_,i_,i_,k_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["2113 swinging on ", \[Delta]aa[f,j,i,i,k]]];
S[ca[-f Subscript[b, i],i,j,k]+ca[f Subscript[b, i],k,j,i]+c[-f Subscript[b, j],k]**aop[1,i]+ca[f Subscript[b, j],i,i,k]+aop[f,i]**\[Delta]a[1,j,k]]
);


S[\[Delta]aa[f_,k_,i_,i_,j_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["3112 swinging on ", \[Delta]aa[f,k,i,i,j]]];
S[ca[-f Subscript[b, i],i,k,j]+ca[f Subscript[b, i],j,k,i]+c[-f Subscript[b, k],j]**aop[1,i]+ca[f Subscript[b, k],i,i,j]+aop[1,i]**\[Delta]a[f,k,j]]
);


S[\[Delta]aa[f_,i_,j_,i_,l_]] /; DQ[i,j,l]\[And]!OQ[j,l] := (
If[VS, Print["Tails commute on ", \[Delta]aa[f,i,j,i,l]]];
\[Delta]aa[f,i,l,i,j] // S
);


S[\[Delta]aa[f_,i_,k_,j_,i_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["1321 swinging on ", \[Delta]aa[f,i,k,j,i]]];
S[ca[-f Subscript[b, i],i,j,k]+ca[f Subscript[b, i],k,j,i]+ca[-f Subscript[b, j],k,i,i]+ac[f Subscript[b, j],i,k,i]+\[Delta]aa[f,i,i,j,k]]
);


S[\[Delta]aa[f_,i_,k_,j_,j_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["1322 swinging on ", \[Delta]aa[f,i,k,j,j]]];
S[ac[-f Subscript[b, i],j,k,j]+ca[f Subscript[b, i],k,j,j]+ca[-f Subscript[b, j],k,i,j]+ca[f Subscript[b, j],j,i,k]+\[Delta]aa[f,j,k,i,j]]
);


S[\[Delta]aa[f_,i_,k_,k_,j_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["1332 swinging on ", \[Delta]aa[f,i,k,k,j]]];
S[c[-f Subscript[b, i],j]**aop[1,k]+ca[f Subscript[b, i],k,k,j]+ca[-f Subscript[b, k],k,i,j]+ca[f Subscript[b, k],j,i,k]+\[Delta]a[f,i,j]**aop[1,k]]
);


S[\[Delta]aa[f_,i_,j_,k_,i_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["1231 swinging on ", \[Delta]aa[f,i,j,k,i]]];
S[ac[-f Subscript[b, i],k,j,i]+ca[f Subscript[b, i],j,k,i]+ca[-f Subscript[b, k],j,i,i]+ac[f Subscript[b, k],i,j,i]+\[Delta]aa[f,i,i,k,j]]
);


S[\[Delta]aa[f_,i_,j_,i_,i_]] /; DQ[i,j]\[And]OQ[i,j]:= (
If[VS, Print["1211 sliding on ", \[Delta]aa[f,i,j,i,i]]];
S[\[Delta]aa[f,i,i,i,j]]
);


S[\[Delta]aa[f_,j_,i_,i_,i_]] /; DQ[i,j]\[And]OQ[i,j]:= (
If[VS, Print["2111 sliding on ", \[Delta]aa[f,j,i,i,i]]];
S[\[Delta]aa[f,i,i,j,i]]
);


S[\[Delta]aa[f_,j_,j_,i_,j_]] /; DQ[i,j]\[And]OQ[i,j]:= (
If[VS, Print["2212 sliding on ", \[Delta]aa[f,j,j,i,j]]];
S[\[Delta]aa[f,i,j,j,j]]
);


S[\[Delta]aa[f_,j_,j_,j_,i_]] /; DQ[i,j]\[And]OQ[i,j]:= (
If[VS, Print["2221 sliding on ", \[Delta]aa[f,j,j,j,i]]];
S[\[Delta]aa[f,j,i,j,j]]
);


S[\[Delta]aa[f_,j_,j_,k_,i_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["2231 swinging on ", \[Delta]aa[f,j,j,k,i]]];
S[ca[-f Subscript[b, j],i,k,j]+ca[f Subscript[b, j],j,k,i]+ac[-f Subscript[b, k],j,i,j]+ca[f Subscript[b, k],i,j,j]+\[Delta]aa[f,j,i,k,j]]
);


S[\[Delta]aa[f_,j_,k_,k_,i_]] /; DQ[i,j,k]\[And]OQ[i,j,k]:= (
If[VS, Print["2331 swinging on ", \[Delta]aa[f,j,k,k,i]]];
S[c[-f Subscript[b, j],i]**aop[1,k]+ca[f Subscript[b, j],k,k,i]+ca[-f Subscript[b, k],k,j,i]+ca[f Subscript[b, k],i,j,k]+\[Delta]a[f,j,i]**aop[1,k]]
);


S[\[Delta]aa[f_,j_,k_,k_,j_]] /; DQ[j,k]:= (
If[VS, Print["Backie swinging on ", \[Delta]aa[f,j,k,k,j]]];
S[c[-f Subscript[b, j],j]**aop[1,k]+ca[f Subscript[b, j],k,k,j]+ca[-f Subscript[b, k],k,j,j]+ac[f Subscript[b, k],j,k,j]+\[Delta]a[f,j,j]**aop[1,k]]
);


Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[0,_] =0; NonCommutativeMultiply[_, 0] = 0;
NonCommutativeMultiply[x_,x_] = 0;
NonCommutativeMultiply[x_Plus, y_] := NonCommutativeMultiply[#,y]& /@ x;
NonCommutativeMultiply[x_, y_Plus] := NonCommutativeMultiply[x,#]& /@ y;


\[Beta][f_]**a[g_,j_,k_] := a[f g, j,k];
\[Beta][f_]**c[g_,j_] := c[f g, j];
c[g_,j_] ** \[Beta][f_] := c[f g, j];
\[Beta][f_]**\[Delta]a[g_,j_,k_] := \[Delta]a[f g, j,k];
\[Beta][f_]**ca[g_,i_,j_,k_] := ca[f g, i,j,k];
ca[g_,i_,j_,k_]**\[Beta][f_] := ca[f g, i,j,k];
\[Beta][f_]**\[Delta]aa[g_,i_,j_,k_,l_] := \[Delta]aa[f g, i,j,k,l];
\[Delta]a[g_,j_,k_] ** \[Beta][f_] := \[Delta]a[f g, j,k];
\[Delta]**a[f_,i_,j_] := \[Delta]a[f,i,j];
c[f_,i_]**a[g_,j_,k_] := ca[f g, i,j,k];
a[f_,i_,j_]**\[Delta]a[g_,k_,l_] := \[Delta]aa[f g,i,j,k,l];
\[Delta]a[f_,i_,j_]**a[g_,k_,l_] := \[Delta]aa[f g,i,j,k,l];


\[Delta]**_c = 0;
\[Delta]**_\[Delta]a = 0;
\[Delta]**_ca = 0;
\[Delta]**_\[Delta]aa = 0;
_c**_c=0;
_c**_\[Delta]a = _\[Delta]a**_c = 0;
_c**_ca = _ca**_c = 0;
_c**_\[Delta]aa = _\[Delta]aa**_c = 0;
_\[Delta]a**_\[Delta]a = 0;
_\[Delta]a**_\[Delta]aa = _\[Delta]aa**_\[Delta]a = 0;
_\[Delta]a**_ca = _ca**_\[Delta]a = 0;


NonCommutativeMultiply::ndef = "NonCommuatativeMultiply is not defined on {`1`,`2`}."
NonCommutativeMultiply[x_,y_] := (Message[NonCommutativeMultiply::ndef, x,y]; Undefined);


B[0,_] =0; B[_, 0] = 0;
B[x_,x_] = 0;
B[x_Plus, y_] := B[#,y]& /@ x;
B[x_, y_Plus] := B[x,#]& /@ y;


\[Gamma][f_, j_,k_] := \[Delta]a[f,j,k]-c[Subscript[b, j]f,k] // S;
\[Gamma][f_, j_,k_,l_] /; DQ[j,k,l] := ca[f,l,j,k] - ca[f,k,j,l] // S;
ac[f_, j_,k_,l_] := ca[f, l,j,k] + B[a[1,j,k], c[f,l]];
aop[f_, j_] := a[f, j,j] + \[Beta][-f Subscript[b, j]]+c[-f,j];


B[a[j_,k_],\[Beta][g_]]:=\[Gamma][\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(j\)]]g\)-\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(k\)]]g\),j,k];
B[\[Beta][g_], a[j_,k_]] := -B[a[j,k], \[Beta][g]];
B[a[j_,k_],a[l_,m_]] /; ({j,k}\[Intersection]{l,m}==={}) := 0;B[a[j_,k_],a[j_,l_]]/;DQ[j,k,l]:=\[Gamma][1,j,k,l] // S;
B[a[j_,k_],a[i_,k_]]/;DQ[i,j,k]:=a[Subscript[b, i],j,k]-a[Subscript[b, j],i,k] // S;
B[a[j_,k_],a[k_,l_]]/;DQ[j,k,l]:=a[Subscript[b, j],k,l]-a[Subscript[b, k],j,l]-\[Gamma][1,j,k,l] // S;
B[a[k_,l_], a[j_,k_]]/;DQ[j,k,l]:= -B[a[j,k],a[k,l]];
(* backie *) B[a[j_,k_], a[k_,j_]] /; DQ[j,k] := a[Subscript[b, j],k,j]-a[Subscript[b, k],j,k]+a[Subscript[b, j],k,k]-a[Subscript[b, k],j,j]+ca[1,k,k,j]-ca[1,j,j,k]+ca[1,k,j,j]-ca[1,j,k,k]+\[Gamma][1,j,k]-\[Gamma][1,k,j];
(* [tail, selfie] *) B[a[j_,k_], a[j_,j_]] /; DQ[j,k] := \[Gamma][1,j,k] //S;
B[a[j_,j_], a[j_,k_]] /; DQ[j,k] := -B[a[j,k], a[j,j]];
(* [head, selfie] *) B[a[j_,k_], a[k_,k_]] /; DQ[j,k] := \[Gamma][-1,j,k] //S;
B[a[k_,k_], a[j_,k_]] /; DQ[j,k] := -B[a[j,k], a[k,k]];
B[a[f_,j_,k_], c[g_,j_]] /; DQ[j,k] := \[Gamma][-f g,j,k];
B[a[f_,j_,k_], c[g_,k_]] /; DQ[j,k] := \[Gamma][f g,j,k];
B[a[f_,j_,k_], c[g_,l_]] /; ({j,k}\[Intersection]{l}==={}) := 0;
B[a[f_,j_,j_], c[g_,j_]] = 0;
B[c[g_,l_], a[f_,j_,k_]] := -B[a[f,j,k], c[g,l]];


B[_\[Beta], _\[Beta]|\[Delta]|_c|_\[Delta]a|_ca|_\[Delta]aa] = 0;
B[_\[Beta]|\[Delta]|_c|_\[Delta]a|_ca|_\[Delta]aa, _\[Beta]] = 0;
B[\[Delta]|_c|_\[Delta]a|_ca|_\[Delta]aa, \[Delta]|_c|_\[Delta]a|_ca|_\[Delta]aa] = 0;


B[a[f_, j_,k_],\[Beta][g_]] :=\[Beta][f]**B[a[j,k],\[Beta][g]];
B[\[Beta][g_], a[f_, j_,k_]] := -B[a[f,j,k], \[Beta][g]];
B[a[f_, j_,k_], a[l_,m_]] := B[\[Beta][f], a[l,m]]**a[1,j,k] + \[Beta][f]**B[a[j,k], a[l,m]];
B[a[f_, j_,k_], a[g_, l_,m_]] := B[a[f,j,k], \[Beta][g]]**a[1,l,m] + \[Beta][g]**B[a[f,j,k], a[l,m]];
B[a[f_,i_,j_], \[Delta]a[g_,k_,l_]] := \[Delta]**B[a[f,i,j], a[g,k,l]];
B[\[Delta]a[f_,i_,j_], a[g_,k_,l_]] := \[Delta]**B[a[f,i,j], a[g,k,l]];
B[a[f_,i_,j_], ca[g_,k_,l_,m_]] := B[a[f,i,j], c[g,k]]**a[1,l,m]+c[g,k]**B[a[f,i,j],a[l,m]];
B[ca[g_,k_,l_,m_], a[f_,i_,j_]] := -B[a[f,i,j], ca[g,k,l,m]];
B[a[f_,i_,j_], \[Delta]aa[g_,k_,l_,m_,n_]] := B[a[f,i,j], \[Delta]a[g,k,l]]**a[1,m,n]+\[Delta]a[g,k,l]**B[a[f,i,j],a[m,n]];
B[\[Delta]aa[g_,k_,l_,m_,n_], a[f_,i_,j_]] := -B[a[f,i,j], \[Delta]aa[g,k,l,m,n]];


B::ndef = "B is not defined on {`1`,`2`}."
B[x_,y_] := (Message[B::ndef, x,y]; Undefined);


FormalBasis[S_List, f_] := Module[{ff, n=Length@S,i,j,k,l},
ff=f@@Table[Subscript[b, S[[i]]], {i,n}];
Flatten@{
\[Beta][ff],
Table[a[ff, S[[i]],S[[j]]], {i,n}, {j,n}],
Table[c[ff, S[[i]]], {i,n}],
Table[\[Delta]a[ff, S[[i]],S[[j]]], {i,n}, {j,n}],
Table[ca[ff, S[[i]],S[[j]],S[[k]]], {i,n}, {j,n}, {k,n}],
Table[\[Delta]aa[ff, S[[i]],S[[j]],S[[k]],S[[l]]], {i,n},{j,n},{k,i,n},{l,j,n}]
} /. 1[___] -> 1
];
FormalBasis[n_Integer, f_] := FormalBasis[Range[n], f];
FormalPlusBasis[n_, f_] := Module[{ff},
ff=f@@Table[Subscript[b, i], {i,n}];
Flatten@{
\[Beta][ff],
Table[a[ff, i,j], {i,n-1}, {j,i+1,n}],
Table[c[ff, i], {i,n}],
Table[\[Delta]a[ff, i,j], {i,n-1}, {j,i+1,n}],
Table[ca[ff, i,j,k], {i,n}, {j,n-1}, {k, j+1,n}],
Table[\[Delta]aa[ff, i,j,k,l], {i,n-1},{j,i+1,n},{k,n-1},{l,k+1,n}]
} /. 1[___] -> 1
];


Jacobi[x1_,x2_,x3_] := Module[{Jac},
Jac=S[B[x1,B[x2,x3]] + B[x2,B[x3,x1]] + B[x3,B[x1,x2]]];
If[Jac===0,Jac,{x1,x2,x3} ->  Jac]
];


AutoAd[x_][y_] := Module[{pows, states, i, s, seq,sh=5, dseq, sf1, sf2, sf, t1, n},
pows = NestList[B[x,#]&, y, 20];
Print["pows computed for ",{x,y},"..."];
states = Union[Cases[pows, s_\[Beta]|s_a|s_c|s_\[Delta]a|s_ca|s_\[Delta]aa :> ReplacePart[s, 1->_], \[Infinity]]];
Sum[
seq=Cases[{#},states[[i]], \[Infinity]]& /@ pows;
seq=Replace[seq,{{_[f_,___]}:>f, {}->0}, {1}];
Print["seq computed... ",states[[i]]," is ",i,"/", Length@states];
dseq=Drop[seq, sh];
If[Union[Length[MonomialList[#]]& /@ dseq]==={1}\[And]Union[Length[FactorTermsList[#]]& /@ dseq]==={2},
sf1 = FindSequenceFunction[FactorTermsList[#][[1]]& /@ dseq];
sf2 = FindSequenceFunction[FactorTermsList[#][[2]]& /@ dseq];
Print["sf1: ", sf1, " sf2: ",sf2];
sf = (sf1[#]sf2[#]&),
(*Else*) sf=FindSequenceFunction[dseq, FunctionSpace->{"ConstantRecursive","HolonomicSequence", "Polynomial", "RationalFunction","HypergeometricTerm"}];
Print["sf: ", sf];
];
ReplacePart[states[[i]], 1 ->Simplify[ \!\(
\*UnderoverscriptBox[\(\[Sum]\), \(n = 0\), \(sh - 1\)]
\*FractionBox[\(seq[[n + 1]]\), \(n!\)]\)+ \!\(
\*UnderoverscriptBox[\(\[Sum]\), \(n = sh\), \(\[Infinity]\)]
\*FractionBox[\(sf[n + 1 - sh]\), \(n!\)]\)]],
{i,Length@states}]
];
(* Hint: Perhaps improve using Variables, CoefficientList, FromCoefficientList *)


Ad[a[t_,j_,k_]][\[Beta][f_]] /; FreeQ[t,Subscript[b, _]] := \[Beta][f]+c[(1-E^(-t Subscript[b, j]))(\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(k\)]]f\)-\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(j\)]]f\)),k]+\[Delta]a[((E^(-t Subscript[b, j])-1) (\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(k\)]]f\)-\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(j\)]]f\)))/Subscript[b, j],j,k];
Ad[a[t_,j_,k_]][a[1,j_,k_]] /; FreeQ[t,Subscript[b, _]] := a[1,j,k];
Ad[a[t_,j_,k_]][a[1,n_,i_]] /; FreeQ[t,Subscript[b, _]]\[And]({j,k}\[Intersection]{n,i}==={}) := a[1,n,i];
Ad[a[t_,j_,k_]][a[1,j_,j_]] /; DQ[j,k]\[And]FreeQ[t,Subscript[b, _]] := a[1,j,j]+c[-1+E^(-t Subscript[b, j]),k]+\[Delta]a[(1-E^(-t Subscript[b, j]))/Subscript[b, j],j,k];
Ad[a[t_,j_,k_]][a[1,k_,k_]] /; DQ[j,k]\[And]FreeQ[t,Subscript[b, _]] :=a[1,k,k]+c[1-E^(-t Subscript[b, j]),k]+\[Delta]a[(-1+E^(-t Subscript[b, j]))/Subscript[b, j],j,k];
Ad[a[t_,j_,k_]][a[1,i_,j_]] /; DQ[i,j,k]\[And]FreeQ[t,Subscript[b, _]] := a[1,i,j]+a[1-E^(-t Subscript[b, j]),i,k]+a[((E^(-t Subscript[b, j])-1) Subscript[b, i])/Subscript[b, j],j,k]+ca[(1-E^(-t Subscript[b, j]))/Subscript[b, j],k,i,j]+ca[(E^(-t Subscript[b, j])-1)/Subscript[b, j],j,i,k]+ca[(Subscript[b, i] (1-E^(-t Subscript[b, j])-t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,j,k]+ca[(E^(-2 t Subscript[b, j]) Subscript[b, i] (1-E^(t Subscript[b, j])-E^(t Subscript[b, j]) (E^(t Subscript[b, j])-2) t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),k,j,k]+ca[(E^(-2 t Subscript[b, j]) (E^(t Subscript[b, j]) (1-t Subscript[b, j])-1))/Subscript[b, j],k,i,k]+\[Delta]a[(Subscript[b, i] (1-E^(-t Subscript[b, j])-t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\)+(-Subscript[b, i] (1-E^(-2 t Subscript[b, j])+(-1-E^(-t Subscript[b, j])) t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,k]+\[Delta]a[(-1+E^(-t Subscript[b, j])+t Subscript[b, j])/Subscript[b, j]+(1-E^(-2 t Subscript[b, j])+(-1-E^(-t Subscript[b, j])) t Subscript[b, j])/Subscript[b, j],i,k]+\[Delta]aa[(2 E^(-t Subscript[b, j]) Subscript[b, i] (Sinh[t Subscript[b, j]]-t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(3\)]\),j,k,j,k]+\[Delta]aa[(-1+E^(-t Subscript[b, j])+t Subscript[b, j])/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),i,j,j,k]+\[Delta]aa[-((1-E^(-2 t Subscript[b, j])+(-1-E^(-t Subscript[b, j])) t Subscript[b, j])/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\)),i,k,j,k];
Ad[a[t_,j_,k_]][a[1,i_,k_]] /; DQ[i,j,k]\[And]FreeQ[t,Subscript[b, _]] := a[E^(-t Subscript[b, j]),i,k]+a[((1-E^(-t Subscript[b, j])) Subscript[b, i])/Subscript[b, j],j,k]+ca[(2 E^(-t Subscript[b, j]) Subscript[b, i] (Sinh[t Subscript[b, j]]-t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),k,j,k]+ca[(E^(-2 t Subscript[b, j]) (1+E^(t Subscript[b, j]) (-1+t Subscript[b, j])))/Subscript[b, j],k,i,k]+\[Delta]a[(E^(-2 t Subscript[b, j]) Subscript[b, i] (-1+E^(t Subscript[b, j]) (1-t Subscript[b, j])))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,k]+\[Delta]a[(E^(-2 t Subscript[b, j]) (1-E^(t Subscript[b, j]) (1-t Subscript[b, j])))/Subscript[b, j],i,k]+\[Delta]aa[(2 E^(-t Subscript[b, j]) Subscript[b, i] (-Sinh[t Subscript[b, j]]+t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(3\)]\),j,k,j,k]+\[Delta]aa[(E^(-2 t Subscript[b, j]) (-1+E^(t Subscript[b, j]) (1-t Subscript[b, j])))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),i,k,j,k];
Ad[a[t_,j_,k_]][a[1,j_,l_]] /; DQ[j,k,l]\[And]FreeQ[t,Subscript[b, _]] := a[1,j,l]+ca[t,l,j,k]+ca[(E^(-t Subscript[b, j])-1)/Subscript[b, j],k,j,l]+\[Delta]aa[(1-E^(-t Subscript[b, j])-t Subscript[b, j])/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,k,j,l];
Ad[a[t_,j_,k_]][a[1,k_,l_]] /; DQ[j,k,l]\[And]FreeQ[t,Subscript[b, _]] := a[E^(t Subscript[b, j]),k,l]+a[-(((-1+E^(t Subscript[b, j])) Subscript[b, k])/Subscript[b, j]),j,l]+ca[(-1+E^(t Subscript[b, j]) (1-t Subscript[b, j]))/Subscript[b, j],k,k,l]+ca[(Subscript[b, j]-E^(-t Subscript[b, j]) Subscript[b, j]+Subscript[b, k]+E^(t Subscript[b, j]) (-1+t Subscript[b, j]) Subscript[b, k])/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),k,j,l]+ca[(Subscript[b, j]+Subscript[b, k]+t Subscript[b, j] Subscript[b, k]-E^(t Subscript[b, j]) (Subscript[b, j]+Subscript[b, k]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),l,j,k]+\[Delta]aa[(1+E^(t Subscript[b, j]) (-1+t Subscript[b, j]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,k,k,l]+\[Delta]aa[(E^(-t Subscript[b, j]) (Subscript[b, j]+E^(2 t Subscript[b, j]) (Subscript[b, j]+(2-t Subscript[b, j]) Subscript[b, k])-E^(t Subscript[b, j]) (2 Subscript[b, k]+Subscript[b, j] (2+t Subscript[b, k]))))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(3\)]\),j,k,j,l];
Ad[a[t_,j_,k_]][a[1,k_,j_]] /; DQ[j,k]\[And]FreeQ[t,Subscript[b, _]] := a[E^(t Subscript[b, j]),k,j]+a[-1+E^(t Subscript[b, j]),k,k]+a[-(((-1+E^(t Subscript[b, j])) Subscript[b, k])/Subscript[b, j]),j,j]+a[-(((-1+E^(t Subscript[b, j])) Subscript[b, k])/Subscript[b, j]),j,k]+c[((1-E^(t Subscript[b, j])+2 E^(t Subscript[b, j]) t Subscript[b, j]) Subscript[b, k])/Subscript[b, j],j]+c[-1+E^(-t Subscript[b, j])+(E^(-t Subscript[b, j]) (1-E^(2 t Subscript[b, j])+2 E^(2 t Subscript[b, j]) t Subscript[b, j]) Subscript[b, k])/Subscript[b, j],k]+ca[E^(t Subscript[b, j]) t,k,k,j]+ca[(-1+E^(t Subscript[b, j])-2 E^(t Subscript[b, j]) t Subscript[b, j])/Subscript[b, j],j,k,k]+ca[(-1+E^(t Subscript[b, j])-E^(t Subscript[b, j]) t Subscript[b, j])/Subscript[b, j],k,k,k]+ca[(-2 (-1+E^(t Subscript[b, j])) Subscript[b, k]+Subscript[b, j] (1-E^(t Subscript[b, j])+2 E^(t Subscript[b, j]) t Subscript[b, k]))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,j,k]+ca[(E^(-t Subscript[b, j]) ((-1+E^(t Subscript[b, j])) Subscript[b, k]+Subscript[b, j] (-1+E^(t Subscript[b, j])-E^(2 t Subscript[b, j]) t Subscript[b, k])))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),k,j,j]+ca[(E^(-t Subscript[b, j]) (-(1-3 E^(t Subscript[b, j])+2 E^(2 t Subscript[b, j])) Subscript[b, k]+Subscript[b, j] (-(-1+E^(t Subscript[b, j]))^2+E^(2 t Subscript[b, j]) t Subscript[b, k])))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),k,j,k]+\[Delta]a[-E^(t Subscript[b, j]) t,k,j]+\[Delta]a[(-1+E^(t Subscript[b, j])-E^(t Subscript[b, j]) t Subscript[b, j])/Subscript[b, j],k,k]+\[Delta]a[-(((1-E^(t Subscript[b, j])+E^(t Subscript[b, j]) t Subscript[b, j]) Subscript[b, k])/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\)),j,j]+\[Delta]a[(E^(-t Subscript[b, j]) ((-1+E^(t Subscript[b, j])) Subscript[b, k]+Subscript[b, j] (-1+E^(t Subscript[b, j])-E^(2 t Subscript[b, j]) t Subscript[b, k])))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,k]+\[Delta]aa[(2-2 E^(t Subscript[b, j])+2 E^(t Subscript[b, j]) t Subscript[b, j])/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,j,k,k]+\[Delta]aa[(2-2 E^(t Subscript[b, j])+2 E^(t Subscript[b, j]) t Subscript[b, j])/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(2\)]\),j,k,k,k]+\[Delta]aa[(E^(-t Subscript[b, j]) ((1-4 E^(t Subscript[b, j])+3 E^(2 t Subscript[b, j])) Subscript[b, k]+Subscript[b, j] ((-1+E^(t Subscript[b, j]))^2-2 E^(2 t Subscript[b, j]) t Subscript[b, k])))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(3\)]\),j,j,j,k]+\[Delta]aa[(E^(-t Subscript[b, j]) ((1-4 E^(t Subscript[b, j])+3 E^(2 t Subscript[b, j])) Subscript[b, k]+Subscript[b, j] ((-1+E^(t Subscript[b, j]))^2-2 E^(2 t Subscript[b, j]) t Subscript[b, k])))/
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(3\)]\),j,k,j,k];
Ad[a[t_,j_,k_]][c[1,i_]] /; FreeQ[t,Subscript[b, _]]\[And]({j,k}\[Intersection]{i}==={}) := c[1,i];
Ad[a[t_,j_,k_]][c[1,j_]] /; DQ[j,k]\[And]FreeQ[t,Subscript[b, _]] := c[1,j]+c[1-E^(-t Subscript[b, j]),k]+\[Delta]a[(E^(-t Subscript[b, j])-1)/Subscript[b, j],j,k];
Ad[a[t_,j_,k_]][c[1,k_]] /; DQ[j,k]\[And]FreeQ[t,Subscript[b, _]] := c[E^(-t Subscript[b, j]),k]+\[Delta]a[(1-E^(-t Subscript[b, j]))/Subscript[b, j],j,k];


Ad[x_\[Beta]|x_c|x_\[Delta]a|x_ca|x_\[Delta]aa][y_] := y+B[x,y];


Ad[x_][a[f_,i_,j_]] /; f=!=1 := Ad[x][\[Beta][f]]**Ad[x][a[1,i,j]];
Ad[x_][c[f_,i_]] /; f=!=1 := Ad[x][\[Beta][f]]**Ad[x][c[1,i]];
Ad[x_][\[Delta]a[f_,j_,k_]] := \[Delta]**(\[Beta][f]**Ad[x][a[1,j,k]]);
Ad[x_][ca[f_,i_,j_,k_]] := Ad[x][c[f,i]]**Ad[x][a[1,j,k]];
Ad[x_][\[Delta]aa[f_,i_,j_,k_,l_]] := Ad[x][\[Delta]a[f,i,j]]**Ad[x][a[1,k,l]];
Ad[x_][y_Plus] := Ad[x] /@ y;


Ad::ndef = "Ad[`1` is not defined on `2`.";
Ad[x_][y_] := (Message[Ad::ndef, x,y]; Undefined);


AdTests[a[t,j,k]] = {\[Beta][f[Subscript[b, j],Subscript[b, k]]], a[1,j,k],a[1,n,i],a[1,j,j],a[1,k,k],c[1, i], c[1, j],c[1, k],a[1,j,l],a[1,i,j],a[1,i,k], a[1,k,l], a[1,k,j]};


VerifyR3[t_,expr_] := Module[{lhs,rhs},
lhs = expr // R[t,1,2] // R[t,1,3] // R[t,2,3] // S;
rhs = expr // R[t,2,3] // R[t,1,3] // R[t,1,2] // S;
expr -> S[lhs-rhs]==0
];
VerifyR3[expr_] := VerifyR3[1,expr];


Subscript[f, 22][__]=0; Subscript[f, 21][__]=0; Subscript[f, 9][__]=0; Subscript[f, 5][__]=0; Subscript[f, 13][__]=0; Subscript[f, 17][__]=0; Subscript[f, 7][__]=0;
Subscript[f, 8][__] =0;
Subscript[f, 10][Subscript[b, j_],Subscript[b, k_]] := Subscript[g, 2][Subscript[b, k]];
Subscript[f, 1][Subscript[b, j_],Subscript[b, k_]] := Subscript[g, 3][Subscript[b, k]];
Subscript[f, 12][Subscript[b, j_],Subscript[b, k_]] := -Subscript[b, j] Subscript[f, 19][Subscript[b, j],Subscript[b, k]];
Subscript[f, 19][Subscript[b, j_],Subscript[b, k_]] := -((E^-Subscript[b, j] (2-2 E^Subscript[b, j]+Subscript[b, j]+E^Subscript[b, j] Subscript[b, j]))/(2 
\!\(\*SubsuperscriptBox[\(b\), \(j\), \(3\)]\)));
Subscript[f, 16][Subscript[b, j_],Subscript[b, k_]] := Subscript[g, 1][Subscript[b, j]];
Subscript[f, 11][Subscript[b, j_],Subscript[b, k_]] := Subscript[g, 4][Subscript[b, j]];
Subscript[f, 14][Subscript[b, j_],Subscript[b, k_]] := -Subscript[b, j] Subscript[f, 20][Subscript[b, j],Subscript[b, k]];
Subscript[f, 20][Subscript[b, j_],Subscript[b, k_]] := (-1+E^Subscript[b, j])/(E^Subscript[b, j] Subscript[b, j]) (-2+2 E^Subscript[b, k]-Subscript[b, k]-E^Subscript[b, k] Subscript[b, k]+2 
\!\(\*SubsuperscriptBox[\(b\), \(k\), \(2\)]\) Subscript[g, 2][Subscript[b, k]]+2 E^Subscript[b, k] 
\!\(\*SubsuperscriptBox[\(b\), \(k\), \(2\)]\) Subscript[g, 4][Subscript[b, k]])/(2 (-1+E^Subscript[b, k]) 
\!\(\*SubsuperscriptBox[\(b\), \(k\), \(2\)]\));
Subscript[f, 2][Subscript[b, j_],Subscript[b, k_]] := Subscript[g, 5][Subscript[b, j]]-Subscript[b, j] Subscript[f, 4][Subscript[b, j],Subscript[b, k]];
(* Non-forced choice: *) Subscript[f, 4][__] =0;
Subscript[g, 5][Subscript[b, j_]] := -((E^-Subscript[b, j] (2-2 E^Subscript[b, j]+Subscript[b, j]+E^Subscript[b, j] Subscript[b, j]+2 Subscript[b, j] Subscript[g, 3][Subscript[b, j]]))/(2 Subscript[b, j]));
(* Non-forced choices: *) Subscript[g, 1][_]=0; Subscript[g, 2][_]=0; Subscript[g, 3][_]=0; Subscript[g, 4][_]=0; Subscript[f, 3][__]=0; Subscript[f, 6][__]=0; Subscript[f, 15][__]=0; Subscript[f, 18][__]=0; Subscript[f, 23][__]=0;
Total[MapIndexed[(#1 /. f->Subscript[f, #2[[1]]])& , DeleteCases[FormalBasis[{j,k},f], _\[Beta]|_a]]] // S


R[t_,j_,k_][x_] := Expand[
x // Ad[a[t,j,k]] // (#+t B[Total[MapIndexed[(#1 /. f->Subscript[f, #2[[1]]])& , DeleteCases[FormalBasis[{j,k},f], _\[Beta]|_a]]], #])&
];
R[j_,k_][x_] := R[1,j,k][x];



