Pensieve header: One-Co computations in the abc presentation, “na nδa nca nδaa” fork; continues pensieve://2015-08/.

The bracket

On the elements β, na, c, nδa, nca, nδaa. (“n” for naive)

Generalities

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

Simp[expr_] := Simplify[expr];
S[β[f_]] := β[Simp[f]];
S[na[i_,j_]] := na[i,j];
S[na[f_, i_,j_]] := na[Simp[f], i,j];
S[c[f_, k_]] := c[Simp[f], k];
S[nδa[f_, i_,j_]] := nδa[Simp[f], i,j];
S[nca[f_, j_,k_,l_]] := nca[Simp[f], j,k,l];
S[nδaa[f_, i_,j_,k_,l_]] := nδaa[Simp[f], i,j,k,l];
S[expr_] := expr /. (λ_β|λ_na|λ_nδa|λ_c|λ_nca|λ_nδaa) :> S[λ];

β[0] :=0;
β /: β[f_] + β[g_] := β[f+g] // S;
β /: g_*β[f_] := β[g f] // S;
na[0,_,_] := 0;
na /: na[f_,j_,k_] + na[g_, j_,k_] := na[f+g, j,k] // S;
na /: g_*na[f_, j_,k_] := na[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;
nδa[0,_,_] := 0;
nδa /: nδa[f_,j_,k_] + nδa[g_, j_,k_] := nδa[f+g, j,k] // S;
nδa /: g_*nδa[f_, j_,k_] := nδa[g f, j,k] // S;
nca[0,_,_,_] :=0;
nca /: nca[f_,j_,k_,l_] + nca[g_, j_,k_,l_] := nca[f+g, j,k,l] // S;
nca /: g_*nca[f_, j_,k_,l_] := nca[g f, j,k,l] // S;
nδaa[0, _,_,_,_] :=0;
nδaa /: nδaa[f_,i_,j_,k_,l_] + nδaa[g_, i_,j_,k_,l_] := nδaa[f+g, i,j,k,l] // S;
nδaa /: g_*nδaa[f_, i_,j_,k_,l_] := nδaa[g f, i,j,k,l] // S;

The γ shortcuts

nγ[f_, j_,k_] := nδa[f,j,k]-c[(Subscript[b, j])f,k] // S;
nγ[f_, j_,k_,l_] /; DQ[j,k,l] := nca[f,l,j,k] - nca[f,k,j,l] // S;
nac[f_, j_,k_,l_] := nca[f, l,j,k] + B[na[1,j,k], c[f,l]];
naop[f_, j_] := na[f, j,j] + β[-f (Subscript[b, j])]+c[-f,j];

NonCommutativeMultiply

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;

β[f_]**na[g_,j_,k_] := na[f g, j,k];
β[f_]**c[g_,j_] := c[f g, j];
c[g_,j_] ** β[f_] := c[f g, j];
β[f_]**nδa[g_,j_,k_] := nδa[f g, j,k];
β[f_]**nca[g_,i_,j_,k_] := nca[f g, i,j,k];
nca[g_,i_,j_,k_]**β[f_] := nca[f g, i,j,k];
β[f_]**nδaa[g_,i_,j_,k_,l_] := nδaa[f g, i,j,k,l];
nδa[g_,j_,k_] ** β[f_] := nδa[f g, j,k];
δ**na[f_,i_,j_] := nδa[f,i,j];
c[f_,i_]**na[g_,j_,k_] := nca[f g, i,j,k];
na[f_,i_,j_]**nδa[g_,k_,l_] := nδaa[f g,i,j,k,l];
nδa[f_,i_,j_]**na[g_,k_,l_] := nδaa[f g,i,j,k,l];

δ**_c = 0;
δ**_nδa = 0;
δ**_nca = 0;
δ**_nδaa = 0;
_c**_c=0;
_c**_nδa = _nδa**_c = 0;
_c**_nca = _nca**_c = 0;
_c**_nδaa = _nδaa**_c = 0;
_nδa**_nδa = 0;
_nδa**_nδaa = _nδaa**_nδa = 0;
_nδa**_nca = _nca**_nδa = 0;

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

Bracket Generalities

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

Fundamental Brackets

a-β, a-c, a-a, AS

B[na[j_,k_],β[g_]]:=nγ[(∂_(Subscript[b, j]))g-(∂_(Subscript[b, k]))g,j,k];
B[β[g_], na[j_,k_]] := -B[na[j,k], β[g]];
B[na[j_,k_],na[l_,m_]] /; ({j,k}⋂{l,m}==={}) := 0;B[na[j_,k_],na[j_,l_]]/;DQ[j,k,l]:=nγ[1,j,k,l] // S;
B[na[j_,k_],na[i_,k_]]/;DQ[i,j,k]:=na[(Subscript[b, i]),j,k]-na[(Subscript[b, j]),i,k] // S;
B[na[j_,k_],na[k_,l_]]/;DQ[j,k,l]:=na[(Subscript[b, j]),k,l]-na[(Subscript[b, k]),j,l]-nγ[1,j,k,l] // S;
B[na[k_,l_], na[j_,k_]]/;DQ[j,k,l]:= -B[na[j,k],na[k,l]];
(* backie *) B[na[j_,k_], na[k_,j_]] /; DQ[j,k] := na[(Subscript[b, j]),k,j]-na[(Subscript[b, k]),j,k]+na[(Subscript[b, j]),k,k]-na[(Subscript[b, k]),j,j]+nca[1,k,k,j]-nca[1,j,j,k]+nca[1,k,j,j]-nca[1,j,k,k]+nγ[1,j,k]-nγ[1,k,j];
(* [tail, selfie] *) B[na[j_,k_], na[j_,j_]] /; DQ[j,k] :=nγ[1,j,k] //S;
B[na[j_,j_], na[j_,k_]] /; DQ[j,k] := -B[na[j,k], na[j,j]];
(* [head, selfie] *) B[na[j_,k_], na[k_,k_]] /; DQ[j,k] := nγ[-1,j,k] //S;
B[na[k_,k_], na[j_,k_]] /; DQ[j,k] := -B[na[j,k], na[k,k]];
B[na[f_,j_,k_], c[g_,j_]] /; DQ[j,k] := nγ[-f g,j,k];
B[na[f_,j_,k_], c[g_,k_]] /; DQ[j,k] := nγ[f g,j,k];
B[na[f_,j_,k_], c[g_,l_]] /; ({j,k}⋂{l}==={}) := 0;
B[na[f_,j_,j_], c[g_,j_]] = 0;
B[c[g_,l_], na[f_,j_,k_]] := -B[na[f,j,k], c[g,l]];

Vanishing brackets

B[_β, _β|δ|_c|_nδa|_nca|_nδaa] = 0;
B[_β|δ|_c|_nδa|_nca|_nδaa, _β] = 0;
B[δ|_c|_nδa|_nca|_nδaa, δ|_c|_nδa|_nca|_nδaa] = 0;

Composite Brackets

B[na[f_, j_,k_],β[g_]] :=β[f]**B[na[j,k],β[g]];
B[β[g_], na[f_, j_,k_]] := -B[na[f,j,k], β[g]];
B[na[f_, j_,k_], na[l_,m_]] := B[β[f], na[l,m]]**na[1,j,k] + β[f]**B[na[j,k], na[l,m]];
B[na[f_, j_,k_], na[g_, l_,m_]] := B[na[f,j,k], β[g]]**na[1,l,m] + β[g]**B[na[f,j,k], na[l,m]];
B[na[f_,i_,j_], nδa[g_,k_,l_]] := δ**B[na[f,i,j], na[g,k,l]];
B[nδa[f_,i_,j_], na[g_,k_,l_]] := δ**B[na[f,i,j], na[g,k,l]];
B[na[f_,i_,j_], nca[g_,k_,l_,m_]] := B[na[f,i,j], c[g,k]]**na[1,l,m]+c[g,k]**B[na[f,i,j],na[l,m]];
B[nca[g_,k_,l_,m_], na[f_,i_,j_]] := -B[na[f,i,j], nca[g,k,l,m]];
B[na[f_,i_,j_], nδaa[g_,k_,l_,m_,n_]] := B[na[f,i,j], nδa[g,k,l]]**na[1,m,n]+nδa[g,k,l]**B[na[f,i,j],na[m,n]];
B[nδaa[g_,k_,l_,m_,n_], na[f_,i_,j_]] := -B[na[f,i,j], nδaa[g,k,l,m,n]];

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

nδaa relations

VS=True;

“First sort tails then sort heads”

Standard Swinging - sorts heads, if support is 4 strands:

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

Locality - sorts tails when supports are disjoint:

S[nδaa[f_,i_,j_,k_,l_]] /; ({i,j}⋂{k,l}==={})∧!OQ[i,k] := (
If[VS, Print["Locality on ", nδaa[f,i,j,k,l]]];
nδaa[f,k,l,i,j] // S
);

Commute Heads - sorts tails when the heads are the same:

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

Commute Head/Tail - sorts tails:

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

Commute Head/Tail - sorts heads where heads & tails are both broken:

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

2113 Swinging - sorts tails:

nδaa[f,j,i,ii,k] // S

S[nδaa[f_,j_,i_,i_,k_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["2113 swinging on ", nδaa[f,j,i,i,k]]];
S[nca[-f (Subscript[b, i]),i,j,k]+nca[f (Subscript[b, i]),k,j,i]+c[-f (Subscript[b, j]),k]**naop[1,i]+nca[f (Subscript[b, j]),i,i,k]+naop[f,i]**nδa[1,j,k]]
);

nδaa[f,j,i,i,k] // S

3112 Swinging - sorts tails:

nδaa[f,k,i,ii,j] // S

S[nδaa[f_,k_,i_,i_,j_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["3112 swinging on ", nδaa[f,k,i,i,j]]];
S[nca[-f (Subscript[b, i]),i,k,j]+nca[f (Subscript[b, i]),j,k,i]+c[-f (Subscript[b, k]),j]**naop[1,i]+nca[f (Subscript[b, k]),i,i,j]+naop[1,i]**nδa[f,k,j]]
);

nδaa[f,k,i,i,j] // S

Tails Commute - sorts heads when the tails are the same:

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

1321 Swinging - sorts heads:

nδaa[f,i,k,j,ii] // S

S[nδaa[f_,i_,k_,j_,i_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["1321 swinging on ", nδaa[f,i,k,j,i]]];
S[nca[-f (Subscript[b, i]),i,j,k]+nca[f (Subscript[b, i]),k,j,i]+nca[-f (Subscript[b, j]),k,i,i]+nac[f (Subscript[b, j]),i,k,i]+nδaa[f,i,i,j,k]]
);

1322 Swinging - sorts heads, but breaks tails:

nδaa[f,i,k,j,jj] // S

S[nδaa[f_,i_,k_,j_,j_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["1322 swinging on ", nδaa[f,i,k,j,j]]];
S[nac[-f (Subscript[b, i]),j,k,j]+nca[f (Subscript[b, i]),k,j,j]+nca[-f (Subscript[b, j]),k,i,j]+nca[f (Subscript[b, j]),j,i,k]+nδaa[f,j,k,i,j]]
);

1332 Swinging - sorts heads:

nδaa[f,i,k,kk,j] // S

S[nδaa[f_,i_,k_,k_,j_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["1332 swinging on ", nδaa[f,i,k,k,j]]];
S[c[-f (Subscript[b, i]),j]**naop[1,k]+nca[f (Subscript[b, i]),k,k,j]+nca[-f (Subscript[b, k]),k,i,j]+nca[f (Subscript[b, k]),j,i,k]+nδa[f,i,j]**naop[1,k]]
);

nδaa[f,i,k,k,j] // S

1231 Swinging - sorts heads:

nδaa[f,i,j,k,ii] // S

S[nδaa[f_,i_,j_,k_,i_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["1231 swinging on ", nδaa[f,i,j,k,i]]];
S[nac[-f (Subscript[b, i]),k,j,i]+nca[f (Subscript[b, i]),j,k,i]+nca[-f (Subscript[b, k]),j,i,i]+nac[f (Subscript[b, k]),i,j,i]+nδaa[f,i,i,k,j]]
);

1211 sliding - sorts heads:

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

2111 sliding - sorts tails:

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

2212 sliding - sorts tails:

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

2221 sliding - sorts heads:

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

2231 Swinging - sorts heads:

nδaa[f,j,jj,k,i] // S

S[nδaa[f_,j_,j_,k_,i_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["2231 swinging on ", nδaa[f,j,j,k,i]]];
S[nca[-f (Subscript[b, j]),i,k,j]+nca[f (Subscript[b, j]),j,k,i]+nac[-f (Subscript[b, k]),j,i,j]+nca[f (Subscript[b, k]),i,j,j]+nδaa[f,j,i,k,j]]
);

2331 Swinging - sorts heads:

nδaa[f,j,k,kk,i] // S

S[nδaa[f_,j_,k_,k_,i_]] /; DQ[i,j,k]∧OQ[i,j,k]:= (
If[VS, Print["2331 swinging on ", nδaa[f,j,k,k,i]]];
S[c[-f (Subscript[b, j]),i]**naop[1,k]+nca[f (Subscript[b, j]),k,k,i]+nca[-f (Subscript[b, k]),k,j,i]+nca[f (Subscript[b, k]),i,j,k]+nδa[f,j,i]**naop[1,k]]
);

Backie jkkj Swinging - sorts tails or heads:

nδaa[f,j,k,kk,jj] // S

S[nδaa[f_,j_,k_,k_,j_]] /; DQ[j,k]:= (
If[VS, Print["Backie swinging on ", nδaa[f,j,k,k,j]]];
S[c[-f (Subscript[b, j]),j]**naop[1,k]+nca[f (Subscript[b, j]),k,k,j]+nca[-f (Subscript[b, k]),k,j,j]+nac[f (Subscript[b, k]),j,k,j]+nδa[f,j,j]**naop[1,k]]
);

Naive / EK Conversions

ToNaive[expr_] := expr /. {
a[f_,j_,k_] /; DQ[j,k] :> na[f,j,k],
a[f_,j_,j_] :> 
}

Testing Jacobi and Anti-Symmetry

FormalBasis[S_List, f_] := Module[{ff, n=Length@S,i,j,k,l},
ff=f@@Table[(Subscript[b, S[[i]]]), {i,n}];
Flatten@{
β[ff],
Table[na[ff, S[[i]],S[[j]]], {i,n}, {j,n}],
Table[c[ff, S[[i]]], {i,n}],
Table[nδa[ff, S[[i]],S[[j]]], {i,n}, {j,n}],
Table[nca[ff, S[[i]],S[[j]],S[[k]]], {i,n}, {j,n}, {k,n}],
Table[nδ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@{
β[ff],
Table[na[ff, i,j], {i,n-1}, {j,i+1,n}],
Table[c[ff, i], {i,n}],
Table[nδa[ff, i,j], {i,n-1}, {j,i+1,n}],
Table[nca[ff, i,j,k], {i,n}, {j,n-1}, {k, j+1,n}],
Table[nδaa[ff, i,j,k,l], {i,n-1},{j,i+1,n},{k,n-1},{l,k+1,n}]
} /. 1[___] -> 1
];

VS=False;
AS[x1_,x2_] := Module[{as},
as=B[x1,x2]+B[x2,x1] // S;
If[as===0,as,{x1,x2} ->  as]
];
DeleteCases[Flatten[Outer[
AS,
FormalPlusBasis[3,f],
FormalPlusBasis[3,g]
]], 0]

AS[x1_,x2_] := Module[{as},
as=B[x1,x2]+B[x2,x1] // S;
If[as===0,as,{x1,x2} ->  as]
];
DeleteCases[Flatten[Outer[
AS,
FormalBasis[3,f],
FormalBasis[3,g]
]], 0]

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

JacPlusErrors=DeleteCases[
bas1=FormalPlusBasis[4,f];
bas2=FormalPlusBasis[4,g];
bas3=FormalPlusBasis[4,h];
Flatten[
Table[Jacobi[bas1[[i]],bas2[[j]],bas3[[k]]],
{i,Length[bas1]-1}, {j, i+1,Length@bas2}, {k,i+1,Length@bas3}]
],
0]

VS=False;
JacErrors=DeleteCases[
bas1=FormalBasis[4,f];
bas2=FormalBasis[4,g];
bas3=FormalBasis[4,h];
Flatten[
Table[Jacobi[bas1[[i]],bas2[[j]],bas3[[k]]],
{i,Length[bas1]-1}, {j, i+1,Length@bas2}, {k,i+1,Length@bas3}]
],
0]

The Adjoint action

AutoAd

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_β|s_na|s_c|s_nδa|s_nca|s_nδaa :> ReplacePart[s, 1->_], ∞]];
Sum[
seq=Cases[{#},states[[i]], ∞]& /@ 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}∧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[ (∑_(n=0)^(sh-1))((seq[[n+1]])/(n!))+ (∑_(n=sh)^∞)((sf[n+1-sh])/(n!))]],
{i,Length@states}]
];
(* Hint: Perhaps improve using Variables, CoefficientList, FromCoefficientList *)

AutoAd[na[t,j,k]][na[1,k,j]]

Ad

Ad[na[t_,j_,k_]][β[f_]] /; FreeQ[t,(Subscript[b, _])] := β[f]+c[(1-(E^(-t (Subscript[b, j]))))((∂_(Subscript[b, k]))f-(∂_(Subscript[b, j]))f),k]+nδa[((((E^(-t (Subscript[b, j])))-1) ((∂_(Subscript[b, k]))f-(∂_(Subscript[b, j]))f))/(Subscript[b, j])),j,k];
Ad[na[t_,j_,k_]][na[1,j_,k_]] /; FreeQ[t,(Subscript[b, _])] := na[1,j,k];
Ad[na[t_,j_,k_]][na[1,n_,i_]] /; FreeQ[t,(Subscript[b, _])]∧({j,k}⋂{n,i}==={}) := na[1,n,i];
Ad[na[t_,j_,k_]][na[1,j_,j_]] /; DQ[j,k]∧FreeQ[t,(Subscript[b, _])] := na[1,j,j]+c[-1+(E^(-t (Subscript[b, j]))),k]+nδa[((1-(E^(-t (Subscript[b, j]))))/(Subscript[b, j])),j,k];
Ad[na[t_,j_,k_]][na[1,k_,k_]] /; DQ[j,k]∧FreeQ[t,(Subscript[b, _])] :=na[1,k,k]+c[1-(E^(-t (Subscript[b, j]))),k]+nδa[((-1+(E^(-t (Subscript[b, j]))))/(Subscript[b, j])),j,k];
Ad[na[t_,j_,k_]][na[1,i_,j_]] /; DQ[i,j,k]∧FreeQ[t,(Subscript[b, _])] := na[1,i,j]+na[1-(E^(-t (Subscript[b, j]))),i,k]+na[((((E^(-t (Subscript[b, j])))-1) (Subscript[b, i]))/(Subscript[b, j])),j,k]+nca[((1-(E^(-t (Subscript[b, j]))))/(Subscript[b, j])),k,i,j]+nca[(((E^(-t (Subscript[b, j])))-1)/(Subscript[b, j])),j,i,k]+nca[(((Subscript[b, i]) (1-(E^(-t (Subscript[b, j])))-t (Subscript[b, j])))/(Subscript[b, j]^2)),j,j,k]+nca[(((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])))/(Subscript[b, j]^2)),k,j,k]+nca[(((E^(-2 t (Subscript[b, j]))) ((E^(t (Subscript[b, j]))) (1-t (Subscript[b, j]))-1))/(Subscript[b, j])),k,i,k]+nδa[(((Subscript[b, i]) (1-(E^(-t (Subscript[b, j])))-t (Subscript[b, j])))/(Subscript[b, j]^2))+((-(Subscript[b, i]) (1-(E^(-2 t (Subscript[b, j])))+(-1-(E^(-t (Subscript[b, j])))) t (Subscript[b, j])))/(Subscript[b, j]^2)),j,k]+nδ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]+nδaa[((2 (E^(-t (Subscript[b, j]))) (Subscript[b, i]) (Sinh[t (Subscript[b, j])]-t (Subscript[b, j])))/(Subscript[b, j]^3)),j,k,j,k]+nδaa[((-1+(E^(-t (Subscript[b, j])))+t (Subscript[b, j]))/(Subscript[b, j]^2)),i,j,j,k]+nδaa[-((1-(E^(-2 t (Subscript[b, j])))+(-1-(E^(-t (Subscript[b, j])))) t (Subscript[b, j]))/(Subscript[b, j]^2)),i,k,j,k];
Ad[na[t_,j_,k_]][na[1,i_,k_]] /; DQ[i,j,k]∧FreeQ[t,(Subscript[b, _])] := na[(E^(-t (Subscript[b, j]))),i,k]+na[(((1-(E^(-t (Subscript[b, j])))) (Subscript[b, i]))/(Subscript[b, j])),j,k]+nca[((2 (E^(-t (Subscript[b, j]))) (Subscript[b, i]) (Sinh[t (Subscript[b, j])]-t (Subscript[b, j])))/(Subscript[b, j]^2)),k,j,k]+nca[(((E^(-2 t (Subscript[b, j]))) (1+(E^(t (Subscript[b, j]))) (-1+t (Subscript[b, j]))))/(Subscript[b, j])),k,i,k]+nδa[(((E^(-2 t (Subscript[b, j]))) (Subscript[b, i]) (-1+(E^(t (Subscript[b, j]))) (1-t (Subscript[b, j]))))/(Subscript[b, j]^2)),j,k]+nδa[(((E^(-2 t (Subscript[b, j]))) (1-(E^(t (Subscript[b, j]))) (1-t (Subscript[b, j]))))/(Subscript[b, j])),i,k]+nδaa[((2 (E^(-t (Subscript[b, j]))) (Subscript[b, i]) (-Sinh[t (Subscript[b, j])]+t (Subscript[b, j])))/(Subscript[b, j]^3)),j,k,j,k]+nδaa[(((E^(-2 t (Subscript[b, j]))) (-1+(E^(t (Subscript[b, j]))) (1-t (Subscript[b, j]))))/(Subscript[b, j]^2)),i,k,j,k];
Ad[na[t_,j_,k_]][na[1,j_,l_]] /; DQ[j,k,l]∧FreeQ[t,(Subscript[b, _])] := na[1,j,l]+nca[t,l,j,k]+nca[(((E^(-t (Subscript[b, j])))-1)/(Subscript[b, j])),k,j,l]+nδaa[((1-(E^(-t (Subscript[b, j])))-t (Subscript[b, j]))/(Subscript[b, j]^2)),j,k,j,l];
Ad[na[t_,j_,k_]][na[1,k_,l_]] /; DQ[j,k,l]∧FreeQ[t,(Subscript[b, _])] := na[(E^(t (Subscript[b, j]))),k,l]+na[-(((-1+(E^(t (Subscript[b, j])))) (Subscript[b, k]))/(Subscript[b, j])),j,l]+nca[((-1+(E^(t (Subscript[b, j]))) (1-t (Subscript[b, j])))/(Subscript[b, j])),k,k,l]+nca[(((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]))/(Subscript[b, j]^2)),k,j,l]+nca[(((Subscript[b, j])+(Subscript[b, k])+t (Subscript[b, j]) (Subscript[b, k])-(E^(t (Subscript[b, j]))) ((Subscript[b, j])+(Subscript[b, k])))/(Subscript[b, j]^2)),l,j,k]+nδaa[((1+(E^(t (Subscript[b, j]))) (-1+t (Subscript[b, j])))/(Subscript[b, j]^2)),j,k,k,l]+nδ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])))))/(Subscript[b, j]^3)),j,k,j,l];
Ad[na[t_,j_,k_]][na[1,k_,j_]] /; DQ[j,k]∧FreeQ[t,(Subscript[b, _])] := na[(E^(t (Subscript[b, j]))),k,j]+na[-1+(E^(t (Subscript[b, j]))),k,k]+na[-(((-1+(E^(t (Subscript[b, j])))) (Subscript[b, k]))/(Subscript[b, j])),j,j]+na[-(((-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]+nca[(E^(t (Subscript[b, j]))) t,k,k,j]+nca[((-1+(E^(t (Subscript[b, j])))-2 (E^(t (Subscript[b, j]))) t (Subscript[b, j]))/(Subscript[b, j])),j,k,k]+nca[((-1+(E^(t (Subscript[b, j])))-(E^(t (Subscript[b, j]))) t (Subscript[b, j]))/(Subscript[b, j])),k,k,k]+nca[((-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])))/(Subscript[b, j]^2)),j,j,k]+nca[(((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]))))/(Subscript[b, j]^2)),k,j,j]+nca[(((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]))))/(Subscript[b, j]^2)),k,j,k]+nδa[-(E^(t (Subscript[b, j]))) t,k,j]+nδa[((-1+(E^(t (Subscript[b, j])))-(E^(t (Subscript[b, j]))) t (Subscript[b, j]))/(Subscript[b, j])),k,k]+nδa[-(((1-(E^(t (Subscript[b, j])))+(E^(t (Subscript[b, j]))) t (Subscript[b, j])) (Subscript[b, k]))/(Subscript[b, j]^2)),j,j]+nδ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]))))/(Subscript[b, j]^2)),j,k]+nδaa[((2-2 (E^(t (Subscript[b, j])))+2 (E^(t (Subscript[b, j]))) t (Subscript[b, j]))/(Subscript[b, j]^2)),j,j,k,k]+nδaa[((2-2 (E^(t (Subscript[b, j])))+2 (E^(t (Subscript[b, j]))) t (Subscript[b, j]))/(Subscript[b, j]^2)),j,k,k,k]+nδ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]))))/(Subscript[b, j]^3)),j,j,j,k]+nδ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]))))/(Subscript[b, j]^3)),j,k,j,k];
Ad[na[t_,j_,k_]][c[1,i_]] /; FreeQ[t,(Subscript[b, _])]∧({j,k}⋂{i}==={}) := c[1,i];
Ad[na[t_,j_,k_]][c[1,j_]] /; DQ[j,k]∧FreeQ[t,(Subscript[b, _])] := c[1,j]+c[1-(E^(-t (Subscript[b, j]))),k]+nδa[(((E^(-t (Subscript[b, j])))-1)/(Subscript[b, j])),j,k];
Ad[na[t_,j_,k_]][c[1,k_]] /; DQ[j,k]∧FreeQ[t,(Subscript[b, _])] := c[(E^(-t (Subscript[b, j]))),k]+nδa[((1-(E^(-t (Subscript[b, j]))))/(Subscript[b, j])),j,k];

Ad[x_β|x_c|x_nδa|x_nca|x_nδaa][y_] := y+B[x,y];

Ad[x_][na[f_,i_,j_]] /; f=!=1 := Ad[x][β[f]]**Ad[x][na[1,i,j]];
Ad[x_][c[f_,i_]] /; f=!=1 := Ad[x][β[f]]**Ad[x][c[1,i]];
Ad[x_][nδa[f_,j_,k_]] := δ**(β[f]**Ad[x][na[1,j,k]]);
Ad[x_][nca[f_,i_,j_,k_]] := Ad[x][c[f,i]]**Ad[x][na[1,j,k]];
Ad[x_][nδaa[f_,i_,j_,k_,l_]] := Ad[x][nδa[f,i,j]]**Ad[x][na[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);

AutoAd - Ad tests

Module[{t1,t2},
{t1=S[AutoAd[na[t,j,k]][#]],
S[Ad[na[t,j,k]][#] - t1]}
]& @ na[1,i,k]

AdTests[na[t,j,k]] = {β[f[(Subscript[b, j]),(Subscript[b, k])]], na[1,j,k],na[1,n,i],na[1,j,j],na[1,k,k],c[1, i], c[1, j],c[1, k],na[1,j,l],na[1,i,j],na[1,i,k], na[1,k,l], na[1,k,j]};

S[AutoAd[na[t,j,k]][#]-Ad[na[t,j,k]][#]]& /@ Take[AdTests[na[t,j,k]],All]

The semi group properties

Module[{t1,t2,t3,t4},
t1=Ad[na[t,j,k]][#] /. (h:(β|na|c|nδa|nca|nδaa))[c_,r___] :> h[SeriesCoefficient[c,{t,0,1}],r];
t2=B[na[1,j,k], #];
t3=# // Ad[na[t,j,k]] // Ad[na[s,j,k]];
t4=# // Ad[na[t+s,j,k]];
# -> S[{t1==t2,t3-t4}]
]& /@ AdTests[na[t,j,k]] // ColumnForm

Verifying R3

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

Total[MapIndexed[(#1 /. f->(Subscript[f, #2[[1]]]))& , DeleteCases[FormalBasis[{j,k},f], _β|_a]]]

(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 (Subscript[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 (Subscript[b, k]^2) (Subscript[g, 2])[(Subscript[b, k])]+2 (E^(Subscript[b, k])) (Subscript[b, k]^2) (Subscript[g, 4])[(Subscript[b, k])])/(2 (-1+(E^(Subscript[b, k]))) (Subscript[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], _β|_na]]] // S

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

Print[VerifyR3[#]]& /@ {na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],1,4], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],2,4], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],3,4], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],4,1], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],4,2], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],4,3]};

Print[VerifyR3[ #]]& /@ {na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],1,2], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],1,3], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],2,3], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],2,1], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],3,1], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],3,2]};

Print[VerifyR3[t,#]]& /@ {na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],1,4], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],2,4], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],3,4], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],4,1], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],4,2], na[f[(Subscript[b, 1]),(Subscript[b, 2]),(Subscript[b, 3]),(Subscript[b, 4])],4,3]};

ρ0=Total[MapIndexed[(#1 /. f->(Subscript[f, #2[[1]]]))& , DeleteCases[FormalBasis[{j,k},f], _β|_na]]]

(Subscript[ϕ, 1])[x_] := (E^(-x))-1; (Subscript[ϕ, 2])[x_]:=(((x+2)(E^(-x))-2+x)/(2x));
ρ=c[-(Subscript[ϕ, 2])[(Subscript[b, j])],k]+nca[(((Subscript[ϕ, 2])[(Subscript[b, j])])/(Subscript[b, j])),k,j,k]+nca[(( (Subscript[ϕ, 1])[(Subscript[b, j])])/((Subscript[b, k])(Subscript[ϕ, 1])[(Subscript[b, k])]))(Subscript[ϕ, 2])[(Subscript[b, k])],k,k,k]+nδaa[((-(Subscript[ϕ, 2])[(Subscript[b, j])])/(Subscript[b, j]^2)),j,k,j,k]+nδaa[((-(Subscript[ϕ, 1])[(Subscript[b, j])])/((Subscript[b, j])(Subscript[b, k])(Subscript[ϕ, 1])[(Subscript[b, k])]))(Subscript[ϕ, 2])[(Subscript[b, k])],j,k,k,k];

ρ0-ρ