CanonicalForm[S[sigma[1,2]]]

H[1]*Ar[1,2]

drules=Sequence@@Der[Ar[1,2]]

k0 = Length[ins = First /@ {drules}];
outs={};
For[k=1, k≤Length[ins], ++k,
AppendTo[outs, newout=Der[drules][ins[[k]]]];
ins = ins ~Join~ Complement[
Union[Cases[{newout}, Y[ijk__, hs_[_]] :> Y[ijk, hs[1]], Infinity]],
ins
]
];
--k;
hs = First[Cases[outs, Y[__, hs_[_]] :> hs, Infinity, 1]];
zero=Table[0,{k}];
e[{{i_}}] := ReplacePart[zero, 1, i];
mat = Replace[
outs /. Y[ijk__, hs[h_]] :> -h e[Position[ins, Y[ijk,hs[1]]]],
0 -> zero,
{1}
];
expmat = MatrixExp[hs, mat]

mat

S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,bc]]]

H[bc[x[1], x[2]]]

lhs=First@CanonicalForm[PH[Coefficient[
Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,H[bc[x[1], x[2]]]]]],
Y[0,1,3]
]]]

rhs=First@CanonicalForm[PH[Coefficient[
Ar[0,1] // S[sigma[1,3],sigma[2,3]],
Y[0,1,3]
]]]

Solve[lhs==rhs, bc]

PH[f] = CanonicalForm[PH[
(f[x[1],x[2]] /. x[i_] :> z*x[i])+O[z]^$CutoffDegree
]]

PH[f] = PH[f] /. Derivative[ds___][f][0...] :> f[ds]

Cases[PH[f], f[___], Infinity]

unknowns = DeclareSeries[bc[x[1], x[2]], $CutoffDegree-1]

PH[bc]

Coefficient[
Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,H[bc[x[1], x[2]]]]]],
Y[0,1,3]
]

eq=Coefficient[
Ar[0,1] // S[Exp[Ar[1,3]+Ar[2,3]+Y[1,2,3,PH[bc]]]],
Y[0,1,3]
] == Coefficient[
Ar[0,1] // S[sigma[1,3],sigma[2,3]],
Y[0,1,3]
]

eq1=Series[Normal[eq] /. z-> 1, Sequence @@ ({#, 0, $CutoffDegree}& /@ {x[1], x[2]})]

sol=First[Solve[eq1, unknowns]]

unknowns /. sol

bch=PH[bc] /. sol

(((1/y)(1-(((E^x)-1)/x) ((x+y)/((E^(x+y))-1)))) /. {x -> z x, y -> z y})+O[z]^($CutoffDegree-1)

(bch /. {x[1]->x, x[2]->y})