Pensieve Header: Figure out if there is a homomorphic expansion for regular red-over-green tangles. (only a start...)

NormalizeP[P[p___]] := P[p] /. Thread[Sort[{p}] -> Range[Length[{p}]]];
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}]}
]
];
InsertAt[k_Integer, P[p1___], P[p2___]] := NormalizeP[P @@ Flatten[{p2} /. k -> k+{p2}/100]];
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]};

InsertAt[2,P[3,2,1],P[3,1,2]]