Pensieve header: Solving for associators in TAUT/SAUT.

SetDirectory["C:/drorbn/AcademicPensieve/Projects/Braidors"];
<< ../WKO4/FreeLie.m;
$SeriesShowDegree=3;

AngleBracket /: λ1_AngleBracket ** λ2_AngleBracket /; Support[λ1]==Support[λ2] := (Subscript[BCH, tb])[λ1, λ2];
AngleBracket /: λ1_AngleBracket ** λ2_AngleBracket := NonCommutativeMultiply[
λ1⋃((#->LS[0])& /@ ⟨Complement[Support@λ2, Support@λ1]⟩),
λ2⋃((#->LS[0])& /@ ⟨Complement[Support@λ1, Support@λ2]⟩)
];
tσ[us_List -> vs_List][ser_LieSeries|ser_CWSeries|ser_AngleBracket] := ser // LieMorphism[Thread[(LW/@us)->(LW/@vs)]];
tσ[u_, v_] := tσ[{u}->{v}];
tσ[us_List -> vs_List][ζ_Es] := tσ[us->vs] /@ ζ;
hσ[xs_List -> ys_List][λ_AngleBracket] := Union[λ∖xs, ⟨Thread[ys-> Table[(Subscript[λ, x]),{x, xs}]]⟩];
hσ[x_, y_] := hσ[{x}->{y}];
dσ[as_List -> bs_List][ζ_] := ζ // tσ[as->bs] // hσ[as->bs];
dσ[a_, b_][ζ_] := ζ // tσ[a,b] // hσ[a,b];
λ_AngleBracket // dΔ[a_,b_,c_] :=(λ∖a)⋃⟨b->(Subscript[λ, a]),c->(Subscript[λ, a])⟩//LieMorphism[LW@a->LW@b+LW@c];
ξ_AngleBracket // σ[s___List] := Module[{ξ1},
ξ1 = ξ // dσ[Range[Length@{s}] -> First /@ {s}];
Do[
ξ1 = ξ1 // dΔ[{s}[[i,1]], {s}[[i,1]], {s}[[i,j]]],
{i,Length@{s}}, {j,2,Length@{s}[[i]]}
];
ξ1
];
AngleBracket /: (((ξ_AngleBracket))^(s_σ)):=ξ//s;

DKS[b[t[1,3],t[2,3]]/24] // αMap[1,2,3]

α=LS[{1,2,3}, αs]; β=LS[{1,2,3}, βs]; γ=LS[{1,2,3}, γs];
αs[1]=αs[2]=αs[3]=βs[1]=βs[2]=βs[3]=γs[1]=γs[2]=γs[3]=0;
αs[2,3]=1/24; βs[1,3]=-1/24;
αs[1,3]=αs[1,2]=βs[1,2]=0;
(Subscript[Φ, 0])=⟨1->α, 2->β,3->γ⟩;
(Subscript[Φ, 0])@{2}

SeriesSolve[{α,β,γ}, (ℏ^(-1))(b[LW@1,α]+b[LW@2,β] +b[LW@3,γ]≡ LS[0])&&((Subscript[Φ, 0])^(σ[3,2,1]))≡-(Subscript[Φ, 0]) && (Subscript[Φ, 0])**((Subscript[Φ, 0])^(σ[1,23,4]))**((Subscript[Φ, 0])^(σ[2,3,4]))≡((Subscript[Φ, 0])^(σ[12,3,4]))**((Subscript[Φ, 0])^(σ[1,2,34]))];
(Subscript[Φ, 0])@{2}

(Subscript[Φ, 0])@{4}

R = DKS[t[1,2]/2] // αMap[1,2]

((R^(σ[12,3])) ≡ (Subscript[Φ, 0])**(R^(σ[2,3]))**(((-(Subscript[Φ, 0])))^(σ[1,3,2]))**(R^(σ[1,3]))**((Subscript[Φ, 0])^(σ[3,1,2]))∧(((-R))^(σ[12,3])) ≡ (Subscript[Φ, 0])**(((-R))^(σ[2,3]))**(((-(Subscript[Φ, 0])))^(σ[1,3,2]))**(((-R))^(σ[1,3]))**((Subscript[Φ, 0])^(σ[3,1,2])))@{6}

R=DKS[t[1,2]/2];
(Subscript[B, 0])=((Subscript[Φ, 0])^(σ[1,2,3]))**(R^(σ[2,3]))**(((-(Subscript[Φ, 0])))^(σ[1,3,2]))

lhs=((Subscript[B, 0])^(σ[1,2,3]))**((Subscript[B, 0])^(σ[13,2,4]))**((Subscript[B, 0])^(σ[1,3,4]))

rhs=((Subscript[B, 0])^(σ[12,3,4]))**((Subscript[B, 0])^(σ[1,2,4]))**((Subscript[B, 0])^(σ[14,2,3]))

(lhs≡rhs)@{6}

Bs[2,1]=Bs[3,1]=0;Bs[3,2]=1/2; (Subscript[B, 1])=DKS[3, Bs];
SeriesSolve[(Subscript[B, 1]),((Subscript[B, 1])^(σ[1,2,3]))**((Subscript[B, 1])^(σ[13,2,4]))**((Subscript[B, 1])^(σ[1,3,4]))≡((Subscript[B, 1])^(σ[12,3,4]))**((Subscript[B, 1])^(σ[1,2,4]))**((Subscript[B, 1])^(σ[14,2,3]))];

(Subscript[B, 1])@{6}

(Subscript[B, 0])@{6}

((Subscript[B, 0])≡(Subscript[B, 1]))@{7}

((Subscript[B, 0])≡(Subscript[B, 1]))@{8}