Pensieve header: Verifying the PBW coherence, following https://chatgpt.com/c/6a0dc8f8-dd54-83ea-9134-36a5dbdbd6d6.

SR={ (* Straightening Rules *)
w[l___,(Subscript[x, c_,d_]),(Subscript[x, a_,b_]),r___]/;a<b<c<d:>w[l,(Subscript[x, a,b]),(Subscript[x, c,d]),r],
w[l___,(Subscript[x, a_,c_]),(Subscript[x, a_,b_]),r___]/;a<b<c:>(q^(-1)) w[l,(Subscript[x, a,b]),(Subscript[x, a,c]),r],
w[l___,(Subscript[x, b_,c_]),(Subscript[x, a_,c_]),r___]/;a<b<c:>(q^(-1))w[l,(Subscript[x, a,c]),(Subscript[x, b,c]),r],
w[l___,(Subscript[x, b_,c_]),(Subscript[x, a_,b_]),r___]/;a<b<c:>q w[l,(Subscript[x, a,b]),(Subscript[x, b,c]),r]-q w[l,(Subscript[x, a,c]),r],
w[l___,(Subscript[x, a_,d_]),(Subscript[x, b_,c_]),r___]/;a<b<c<d:>w[l,(Subscript[x, b,c]),(Subscript[x, a,d]),r],
w[l___,(Subscript[x, b_,d_]),(Subscript[x, a_,c_]),r___]/;a<b<c<d:>w[l,(Subscript[x, a,c]),(Subscript[x, b,d]),r]-(q-(q^(-1)))w[l,(Subscript[x, b,c]),(Subscript[x, a,d]),r]
};

Straighten[ℰ_]:=FixedPoint[Expand[#/.SR]&,ℰ,10]

Straighten[w[(Subscript[x, 1,2]),(Subscript[x, 2,3])]]

Straighten[w[(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

Straighten[w[(Subscript[x, 1,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

Straighten[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

AllSingleSteps[ℰ_]:=Union@Expand@Flatten[
Map[
p|->MapAt[
ω|->Replace[{}->{ω}]@ReplaceList[SR]@ω,
{ℰ},p
],
Position[{ℰ},_w,∞]
]
];
AllSingleSteps[ℒ_List]:=Union@Flatten[AllSingleSteps/@ℒ]

AllSingleSteps[w[(Subscript[x, 1,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

AllSingleSteps@{((w[(Subscript[x, 1,3]),(Subscript[x, 1,4]),(Subscript[x, 1,2])])/q),((w[(Subscript[x, 1,4]),(Subscript[x, 1,2]),(Subscript[x, 1,3])])/q)}

AllSingleSteps@{((w[(Subscript[x, 1,2]),(Subscript[x, 1,4]),(Subscript[x, 1,3])])/(q^2)),((w[(Subscript[x, 1,3]),(Subscript[x, 1,2]),(Subscript[x, 1,4])])/(q^2))}

Straightenings[ℰ_]:=FixedPoint[(Echo[Test/@#];AllSingleSteps[#])&,ℰ,50]

Straightenings[w[(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

Straightenings[w[(Subscript[x, 1,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

Straighten@w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]

Straightenings[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

AllSingleSteps[w[(Subscript[x, 2,4]),(Subscript[x, 1,3])]]

AllSingleSteps[{w[(Subscript[x, 1,3]),(Subscript[x, 2,4])]+((w[(Subscript[x, 2,3]),(Subscript[x, 1,4])])/q)-q w[(Subscript[x, 2,3]),(Subscript[x, 1,4])]}]

AllSingleSteps[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

AllSingleSteps/@{w[(Subscript[x, 1,3]),(Subscript[x, 2,4]),(Subscript[x, 1,2])]+((w[(Subscript[x, 2,3]),(Subscript[x, 1,4]),(Subscript[x, 1,2])])/q)-q w[(Subscript[x, 2,3]),(Subscript[x, 1,4]),(Subscript[x, 1,2])],((w[(Subscript[x, 2,4]),(Subscript[x, 1,2]),(Subscript[x, 1,3])])/q)}

Straightenings[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

Test[ℰ_]:=Length@Union[Straighten/@AllSingleSteps[ℰ]]

Test[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

Straighten/@AllSingleSteps[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

AllSingleSteps[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]

Test[w[(Subscript[x, 1,3]),(Subscript[x, 2,4]),(Subscript[x, 1,2])]+((w[(Subscript[x, 2,3]),(Subscript[x, 1,4]),(Subscript[x, 1,2])])/q)-q w[(Subscript[x, 2,3]),(Subscript[x, 1,4]),(Subscript[x, 1,2])]]

Test[((w[(Subscript[x, 2,4]),(Subscript[x, 1,2]),(Subscript[x, 1,3])])/q)]

Test/@AllSingleSteps[w[(Subscript[x, 1,3]),(Subscript[x, 2,4]),(Subscript[x, 1,2])]+((w[(Subscript[x, 2,3]),(Subscript[x, 1,4]),(Subscript[x, 1,2])])/q)-q w[(Subscript[x, 2,3]),(Subscript[x, 1,4]),(Subscript[x, 1,2])]]

Test/@AllSingleSteps[((w[(Subscript[x, 2,4]),(Subscript[x, 1,2]),(Subscript[x, 1,3])])/q)]

Straighten/@Straightenings[w[(Subscript[x, 2,4]),(Subscript[x, 1,3]),(Subscript[x, 1,2])]]