Pensieve Header: Figure out if there is a homomorphic expansion for red-over-green tangles.

Basis[n_] := DeleteCases[
Permutations[P@@Range[n]],
Alternatives[
P[___,i_,j_,___] /; i==j+1 ,
P[___, i_, j_, k_, ___] /; i==j+2 && k==j+1
]
];
P /: p1_P ** p2_P := Join[p1, (Length[p1]+#)& /@ p2];
ASeries /: c_?NumberQ * a_ASeries := Expand[c#]& /@ a;
ASeries /: a1_ASeries + a2_ASeries := Module[
{m=Min[Length[a1], Length[a2]]},
ASeries@@(Take[List@@a1,m]+Take[List@@a2,m])
];
ASeries /: a1_ASeries ** a2_ASeries := Module[
{m=Min[Length[a1], Length[a2]]-1, P1, P2},
ASeries @@ Table[
Sum[
Expand[(a1[[d1+1]] /. P ->P1)*(a2[[d-d1+1]] /. P->P2)],
{d1, 0, d}
],
{d, 0, m}
] /. p1_P1*p2_P2 :> (P@@p1)**(P@@p2)
];
Invert[ASeries[P[], x___]] := Module[
{s, t, k},
t=ReplacePart[ASeries@@Table[0, {1+Length[{x}]}], 1->P[]];
t+Sum[
t = (-t)**ASeries[0,x],
{Length[{x}]}
]
];
GT[p_P] := Reverse[p] //. {
P[l___,i_,j_,r___] /; i==j+1  :> P[l,j,i,r],
P[l___, i_, j_, k_, r___] /; i==j+2 && k==j+1 :> P[l,j,k,i,r]
};
GT[expr_] := expr /. p_P :> GT[p];
EQ1[R_ASeries] := R**Invert[R];
EQ2[R_ASeries] := GT[R] ** GT[Invert[R]];
EQ[R_ASeries] := {EQ1[R], EQ2[R]};

Basis /@ Range[0,4]

GT[Basis /@ Range[0,4]]

R2 = ASeries[P[], P[1], a2 P[1,2]]

Invert[R2]

EQ[R2]

R3p = Append[R2, Array[a3, {Length[Basis[3]]}].Basis[3]]

Invert[R3p]

EQ[R3p]

R3 = R3p /. {a2->1/2}

EQ[R3]

R4p = Append[R3, Array[a4, {Length[Basis[4]]}].Basis[4]]

EQ[R4p]

{R4=R4p /. {a3[1]->0, a3[2] -> 1/8}, EQ[R4]}