Pensieve Header: The Algebra of Emergent Chord Diagrams.

Goal: Implement (Subscript[𝕆, red,ps:{},ss:{}])[(Subscript[𝒜, 0])[(∏_(s∈ss))(Subscript[AW, s])[..]]
+(∑_(s1<=s2))(Subscript[𝒜, t[s1,s2]])[(∏_(s∈ss⋃{(OverBar[s1]),(OverBar[s2])}))(Subscript[AW, s])[..]]  ],
including ⊗, (Subscript[m, i,j->k]) (only if {i,j} are neighbors), (Subscript[𝕆, ss]), CF (Canonical Form) and HCF (HOMFLYPT Canonical Form).

SetDirectory["C:\\drorbn\\AcademicPensieve\\People\\Kuno"];
<< FAA.m

(Subscript[𝒜, a_])[A1_]+(Subscript[𝒜, a_])[A2_]^:=(Subscript[𝒜, a])[A1+A2];
c_*(Subscript[𝒜, a_])[A_]^:=𝒜[Expand[c A]]

CF[(Subscript[𝕆, red_,ps_,ss_])[x_Plus]]:=(Subscript[𝕆, red,ps,ss])[red/@x]

AR[(Subscript[𝒜, 0])[A_]]:=(Subscript[𝒜, 0])[A];
AR[(Subscript[𝒜, t[s_]])[A_]]:=Module[{l,r},(Subscript[𝒜, t[s]])[A//(Subscript[Δ, (OverTilde[s])->l,r])//(Subscript[m, (OverBar[s]),l->(OverBar[s])])//(Subscript[m, t,r->t])//(Subscript[Δ, t->l,r])//(Subscript[m, s,r->s])//(Subscript[S, l->l])//(Subscript[m, l,(OverBar[s])->(OverBar[s])])]];
AR[(Subscript[𝒜, t[s1_,s2_]])[A_]]:=Module[{l,r},(Subscript[𝒜, t[s1,s2]])[A//(Subscript[Δ, (OverBar[s1])->l,r])//(Subscript[m, s1,l->s1])//(Subscript[S, r->r])//(Subscript[m, r,t->t])//(Subscript[Δ, (OverBar[s2])->l,r])//(Subscript[m, t,l->t])//(Subscript[m, s2,r->s2])]];

In the cell below we are confusing the projection A->H with the canonical form in H!

HR[(Subscript[𝒜, 0])[A_]]:=(Subscript[𝒜, 0])[A];
HR[(Subscript[𝒜, t[s_]])[A_]]:=Module[{l,r},(Subscript[𝒜, t[s]])[A//(Subscript[Δ, t->l,r])//(Subscript[m, s,r->s])//(Subscript[m, (OverTilde[s]),s->s])//(Subscript[S, l->l])//(Subscript[m, l,(OverBar[s])->(OverBar[s])])//(Subscript[tr, (OverBar[s])->(OverBar[s])])]];
HR[(Subscript[𝒜, t[s1_,s2_]])[A_]]:=Module[{l,r},(Subscript[𝒜, t[s1,s2]])[A//(Subscript[Δ, t->l,r])//(Subscript[m, s1,l->s1])//(Subscript[S, r->r])//(Subscript[m, s2,r->s2])//(Subscript[m, s1,(OverBar[s2])->s1])//(Subscript[m, s2,(OverBar[s1])->s2])]];

D1=(Subscript[𝕆, AR,{x,y,z},{1,2}])[
(Subscript[𝒜, 0])[(Subscript[AW, 1])[x,y,x](Subscript[AW, 2])[x,x,y]]+
(Subscript[𝒜, t[1,2]])[(Subscript[AW, t])[](Subscript[AW, 1])[x,y](Subscript[AW, 2])[y,x](Subscript[AW, (OverBar[1])])[z](Subscript[AW, (OverBar[2])])[x,y]]
]//CF

D2=(Subscript[𝕆, HR,{x,y,z},{1,2}])[
(Subscript[𝒜, 0])[(Subscript[AW, 1])[x,y,x](Subscript[AW, 2])[x,x,y]]+
(Subscript[𝒜, t[1,2]])[(Subscript[AW, 1])[x,y](Subscript[AW, 2])[y,x](Subscript[AW, (OverBar[1])])[z](Subscript[AW, (OverBar[2])])[x,y]]
]//CF

(Subscript[𝕆, ss_])[(Subscript[𝕆, red_,ps_,s0s_])[(Subscript[𝒜, 0])[A_]+y_]]:= CF@Module[{i,j,s1,s2,u1,u2},
(Subscript[𝕆, red,ps,ss])[Plus[
(Subscript[𝒜, 0])[A],
y/.(Subscript[𝒜, t[s1_,s2_]])[A1_]/;Position[ss,s1][[1,1]]>Position[ss,s2][[1,1]]:>(Subscript[𝒜, t[s2,s1]])[A1//(Subscript[S, t->t])],
Sum[
If[Position[s0s,s1=ss[[i]]][[1,1]]<Position[s0s,s2=ss[[j]]][[1,1]],0,
Sum[
(Subscript[𝒜, t[s1,s2]])[Expand[A((Subscript[AW, u1])[p](Subscript[AW, u2])[]-(Subscript[AW, u1])[](Subscript[AW, u2])[p])(Subscript[AW, t])[]]//(Subscript[D[p], s1->s1,(OverBar[s1])])//(Subscript[D[p], s2->s2,(OverBar[s2])])//(Subscript[m, s1,u1->s1])//(Subscript[m, s2,u2->s2])],
{p,ps}
]
],
{i,Length[ss]-1},{j,i+1,Length@ss}
]
]]]

D1

D1//(Subscript[𝕆, {2,1}])

D1//(Subscript[𝕆, {2,1}])//(Subscript[𝕆, {1,2}])

(D1//(Subscript[𝕆, {2,1}])//(Subscript[𝕆, {1,2}]))-D1

{D2, D2//(Subscript[𝕆, {2,1}]), D2//(Subscript[𝕆, {2,1}])//(Subscript[𝕆, {1,2}])}

(Subscript[𝕆, red_,ps_,ss_])[]//(Subscript[m, i_,j_->k_]):=

CF[(Subscript[𝒜, ps_,ss_])[A0_,A1_]]:=Module[{l,r,u},
(Subscript[𝒜, ps,ss])[A0,A1/.(Subscript[t, i_,j_])ℰ_:>Expand[
(Subscript[t, i,j])(ℰ//(Subscript[Δ, (OverBar[j])->u,l])//(Subscript[S, u->u])//(Subscript[m, u,(OverBar[i])->(OverBar[i])])//(Subscript[Δ, l->l,r])//(Subscript[m, i,l->i])//(Subscript[m, j,r->j]))
]]
]

(Subscript[𝒜, {x,y,z},{1,2}])[
(Subscript[AW, 1])[x,y,x](Subscript[AW, 2])[x,x,y],
(Subscript[t, 1,2])(Subscript[AW, 1])[x,y](Subscript[AW, 2])[y,x](Subscript[AW, (OverBar[1])])[z](Subscript[AW, (OverBar[2])])[x,y]
]//CF

HCF[(Subscript[𝒜, ps_,ss_])[A0_,A1_]]:=(Subscript[𝒜, ps,ss])[A0,A1/.(Subscript[t, i_,j_])ℰ_:>Expand[
(Subscript[t, i,j])(ℰ//(Subscript[m, i,(OverBar[j])->i])//(Subscript[m, j,(OverBar[i])->j]))
]]

(Subscript[𝒜, {x,y,z},{1,2}])[
(Subscript[AW, 1])[x,y,x](Subscript[AW, 2])[x,x,y],
(Subscript[t, 1,2])(Subscript[AW, 1])[x,y](Subscript[AW, 2])[y,x](Subscript[AW, (OverBar[1])])[z](Subscript[AW, (OverBar[2])])[x,y]
]//HCF

Unprotect[NonCommutativeMultiply];(Subscript[𝒜, ps_,ss_])[A0_,A1_]**(Subscript[𝒜, ps_,ss_])[B0_,B1_]:=Module[{ν,T},(Subscript[𝒜, ps,ss])[
T=B0; Do[T=T//(Subscript[σ, s->ν@s]),{s,ss}];
T=Expand[A0 T]; Do[T=T//(Subscript[m, s,ν@s->s]),{s,ss}];
T,
Plus[
T=B1; Do[T=T//(Subscript[σ, s->ν@s]),{s,ss}];
T=Expand[A0 T]; Do[T=T//(Subscript[m, s,ν@s->s]),{s,ss}];
T,
A1B0,
A0B0
]
]]

(Subscript[𝒜, {x,y,z},{1,2}])[(Subscript[AW, 1])[x,y,x](Subscript[AW, 2])[x,x,y],777]**(Subscript[𝒜, {x,y,z},{1,2}])[(Subscript[AW, 1])[z,z,x](Subscript[AW, 2])[x,z,z],888]