α=UndeterminedLieSeries[{"1","2"}, αs];
β=UndeterminedLieSeries[{"1","2"}, βs];
γ=UndeterminedCWSeries[{"1","2"}, γs];
V=(Subscript[E, s])[⟨1->α, 2->β⟩, γ];
κ=UndeterminedCWSeries[{"1"}, κs];
SeriesSolve[
(SuperPlus[R])[2,3]**(SuperPlus[R])[1,3]**V ≡ V**((SuperPlus[R])[1,3] // dΔ[1,1,2])
&& V**(V // dA[1] // dA[2]) ≡ dϵ[1]⋃dϵ[2]
&& V**(κ // dΔ[1,1,2])  // dc[1] // dc[2] ≡ κ⋃(κ//dσ[1,2]),
{α,β,γ,κ},
Arbitrator -> 0 (* should be 0 or a pure function that takes a list of unsettled variables and returns a list of their arbitrated values *)
]

SetOptions[SeriesSolve, Arbitrator -> 0 (* should be 0 or a pure function that takes a list of unsettled variables and returns a list of their arbitrated values *)];

SeriesSolve[{
α=LS[{"1","2"}, αs], β=LS[{"1","2"}, βs],
γ=CWS[{"1","2"}, γs], κ=CWS[{"1"}, κs]
},
V=(Subscript[E, s])[⟨1->α, 2->β⟩, γ];
(ℏ^(-1))((Subscript[ζ, s])[(SuperPlus[R])[2,3]**(SuperPlus[R])[1,3]]**V ≡ V**((Subscript[ζ, s])[(SuperPlus[R])[1,3]]//dΔ[1,1,2]))
&& V**(V//dA[1]//dA[2]) ≡ (Subscript[E, s])[⟨1->0, 2->0⟩,0]
&& V**(κ//dΔ[1,1,2])//dc[1]//dc[2] ≡ κ⋃(κ//dσ[1,2])]

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

(SuperPlus[R])[a_,b_] // (Subscript[ζ, t:(l|s)]) := (Subscript[E, t])[⟨a->LS[0], b->LS[LW@a]⟩, CWS[0]];
(SuperMinus[R])[a_,b_] // (Subscript[ζ, t:(l|s)]) := (Subscript[E, t])[⟨a->LS[0], b->-LS[LW@a]⟩, CWS[0]];
(Subscript[ζ, t:(l|s)])[K1_**K2_] := (Subscript[ζ, t])[K1]**(Subscript[ζ, t])[K2];
(Subscript[ζ, t:(l|s)])[K1_ K2_] := (Subscript[ζ, t])[K1](Subscript[ζ, t])[K2];

SeriesSolve[{
α=LS[{"1","2"}, αs], β=LS[{"1","2"}, βs],
γ=CWS[{"1","2"}, γs], κ=CWS[{"1"}, κs]
},
V=(Subscript[E, s])[⟨1->α, 2->β⟩, γ]; Cap=Es[⟨1->LS[0]⟩,κ];
(ℏ^(-1))((Subscript[ζ, s])[(SuperPlus[R])[2,3]**(SuperPlus[R])[1,3]]**V ≡ V**((Subscript[ζ, s])[(SuperPlus[R])[1,3]] // dΔ[1,1,2]))
&& V**(V//dA[1]//dA[2]) ≡ (Subscript[E, s])[⟨1->LS[0], 2->LS[0]⟩,CWS[0]]
&& (V**(Cap//dΔ[1,1,2])//dc[1]//dc[2]) ≡ (Cap(Cap//dσ[1,2])//dc[1]//dc[2])
]

V@{5}

κ@{8} // Timing

V//Λ

(V//Λ)@{6}

{α=LS[{"1","2"}, αs], β=LS[{"1","2"}, βs],
γ=CWS[{"1","2"}, γs], κ=CWS[{"1"}, κs]}

V=(Subscript[E, s])[⟨1->α, 2->β⟩, γ]

V**(Es[⟨1->0⟩,κ]//dΔ[1,1,2])//dc[1]//dc[2]

(V**(Es[⟨1->0⟩,κ]//dΔ[1,1,2])//dc[1]//dc[2]) ≡ (Es[⟨1->0⟩,κ](Es[⟨1->0⟩,κ]//dσ[1,2])//dc[1]//dc[2])

unknowns={
α=LS[{"1","2"}, αs], β=LS[{"1","2"}, βs],
γ=CWS[{"1","2"}, γs], κ=CWS[{"1"}, κs]
}

V=(Subscript[E, s])[⟨1->α, 2->β⟩, γ]

arbitrator = Replace[#, _->0, 1]&

d=1

eqns=(ℏ^(-1))((Subscript[ζ, s])[(SuperPlus[R])[2,3]**(SuperPlus[R])[1,3]]**V ≡ V**((Subscript[ζ, s])[(SuperPlus[R])[1,3]] // dΔ[1,1,2]));
lineqs=eqns[d]

lineqs=If[Head[lineqs]===And, List @@ lineqs, List@lineqs]

gens=Union[Cases[lineqs, _LW|_CW, ∞]]

lineqs=Flatten[Replace[lineqs ,
lhs_==rhs_ :> ((Coefficient[lhs, #]==Coefficient[rhs,#])& /@ gens),
{1}]]

vars = Union@@((#[d, UndeterminedCoefficients])& /@ unknowns)

{sol}=Solve[lineqs, vars]

fvars=Complement[vars, First /@ sol]

MapThread[(#1=#2)& , {fvars, arbitrator[fvars]}]

sol /. (Rule -> Set)

(#[d]=#[d])& /@ (First /@ unknowns)

d=2

eqns=(ℏ^(-1))((Subscript[ζ, s])[(SuperPlus[R])[2,3]**(SuperPlus[R])[1,3]]**V ≡ V**((Subscript[ζ, s])[(SuperPlus[R])[1,3]] // dΔ[1,1,2]));
lineqs=eqns[d]

lineqs=If[Head[lineqs]===And, List @@ lineqs, List@lineqs]

gens=Union[Cases[lineqs, _LW|_CW, ∞]]

lineqs=Flatten[Replace[lineqs ,
lhs_==rhs_ :> ((Coefficient[lhs, #]==Coefficient[rhs,#])& /@ gens),
{1}]]

vars = Union@@((#[d, UndeterminedCoefficients])& /@ unknowns)

{sol}= Quiet[Solve[lineqs, vars], {Solve::svars}]