Pensieve Header: The Algebra of Emergent Chord Diagrams.

Goal: Implement (Subscript[𝕆, red,ps:{},ss:{}])[(Subscript[𝒜, 0])[(∏_(s∈ss))(Subscript[AW, s])[..]]
+(∑_(s1<=s2))(Subscript[𝒜, c[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"];
<<FreeLie.m
<<AwCalculus.m
<< FAA.m

X=LW@"x";Y=LW@"y";U=LW@"u";
{F=LS[{X,Y}, Fs], G=LS[{X,Y}, Gs]}; Fs["y"]=1/2;
SeriesSolve[{F,G},
(ℏ^(-1))(LS[X+Y]-BCH[Y,X]≡F-G-Ad[-X][F]+Ad[Y][G])∧(Subscript[div, X])[F]+(Subscript[div, Y])[G]≡(1/2)(Subscript[tr, U])[adSeries[(ad/((E^ad)-1)), X][U]+adSeries[(ad/((E^ad)-1)), Y][U]-adSeries[(ad/((E^ad)-1)), BCH[X,Y]][U]]];
{F,G}

(Subscript[Basis, d_])[(Subscript[𝕆, AR,ps_,ss_])]:=(Subscript[𝕆, AR,ps,ss])/@Flatten[{
(Subscript[𝒜, 0])/@(Subscript[Basis, d,ps])[Product[(Subscript[AW, s]),{s,ss}]],
Table[(Subscript[𝒜, c[ss[[i]]]])/@((Subscript[Basis, d-1,ps])[Product[(Subscript[AW, s]),{s,ss}](Subscript[AW, (OverBar[ss[[i]]])])](Subscript[AW, (OverTilde[ss[[i]]])])[]),{i,Length[ss]}],
Table[(Subscript[𝒜, c[ss[[i]],ss[[j]]]])/@((Subscript[Basis, d-1,ps])[Product[(Subscript[AW, s]),{s,ss}](Subscript[AW, (OverBar[ss[[i]]])])](Subscript[AW, (OverBar[ss[[j]]])])[]),{i,Length[ss]-1},{j,i+1,Length@ss}]
}]

(Subscript[Basis, 2])[(Subscript[𝕆, AR,{x,y},{1,2}])]

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

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

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

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

D1=(Subscript[𝕆, AR,{x,y,z},{1,2}])[
(Subscript[𝒜, 0])[(Subscript[AW, 1])[x,y,x](Subscript[AW, 2])[x,x,y]]+
(Subscript[𝒜, c[1,2]])[(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[𝒜, c[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_])[y_]]/;FreeQ[y,(Subscript[𝒜, 0])]:= CF@Module[{s1,s2},
(Subscript[𝕆, red,ps,ss])[
y/.(Subscript[𝒜, c[s1_,s2_]])[A1_]/;Position[ss,s1][[1,1]]>Position[ss,s2][[1,1]]:>red[(Subscript[𝒜, c[s2,s1]])[A1]]
]];
(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[𝒜, c[s1_,s2_]])[A1_]/;Position[ss,s1][[1,1]]>Position[ss,s2][[1,1]]:>red[(Subscript[𝒜, c[s2,s1]])[A1]],
Sum[
If[Position[s0s,s1=ss[[i]]][[1,1]]<Position[s0s,s2=ss[[j]]][[1,1]],0,
Sum[
red[(Subscript[𝒜, c[s1,s2]])[Expand[A((Subscript[AW, u1])[p](Subscript[AW, u2])[]-(Subscript[AW, u1])[](Subscript[AW, u2])[p])]//(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}
]
]]]

(Subscript[𝕆, AR,{x,y},{1,2}])[(Subscript[𝒜, 0])[(Subscript[AW, 1])[x,y,y] (Subscript[AW, 2])[x]]]//(Subscript[𝕆, {2,1}])

Total@Table[B==(B//(Subscript[𝕆, {2,1,3}])//(Subscript[𝕆, {1,2,3}])),{B,(Subscript[Basis, 3])[(Subscript[𝕆, AR,{x,y},{1,2,3}])]}]

(Subscript[𝕆, red_,ps_,ss_])[ℰ_]//(Subscript[m, i_,j_->k_]):=CF@(Subscript[𝕆, red,ps,{k}~Join~Complement[ss,{i,j}]])[First[(Subscript[𝕆, red,ps,ss])[ℰ]//(Subscript[𝕆, {i,j}~Join~Complement[ss,{i,j}]])]/.{
(Subscript[𝒜, c[i,j]])[A_]:>(Subscript[𝒜, c[k]])[A//(Subscript[σ, (OverBar[j])->(OverTilde[k])])//(Subscript[m, (OverBar[i]),j->(OverBar[k])])//(Subscript[σ, i->k])],
(Subscript[𝒜, c[i]])[A_]:>(Subscript[𝒜, c[k]])[A//(Subscript[m, (OverTilde[i]),j->(OverTilde[k])])//(Subscript[σ, i->k])//(Subscript[σ, (OverBar[i])->(OverBar[k])])],
(Subscript[𝒜, c[j]])[A_]:>(Subscript[𝒜, c[k]])[A//(Subscript[m, i,j->k])//(Subscript[σ, (OverBar[j])->(OverBar[k])])//(Subscript[σ, (OverTilde[j])->(OverTilde[k])])],
(Subscript[𝒜, c[i,x_]])[A_]:>(Subscript[𝒜, c[k,x]])[A//(Subscript[m, (OverBar[i]),j->(OverBar[k])])//(Subscript[σ, i->k])],
(Subscript[𝒜, c[j,x_]])[A_]:>(Subscript[𝒜, c[k,x]])[A//(Subscript[m, i,j->k])//(Subscript[σ, (OverBar[j])->(OverBar[k])])],
(Subscript[𝒜, a_])[A_]:>(Subscript[𝒜, a])[A//(Subscript[m, i,j->k])]
}]

Total@Table[(B//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))==(B//(Subscript[m, 2,3->2])//(Subscript[m, 1,2->1])),{B,(Subscript[Basis, 3])[(Subscript[𝕆, AR,{x,y},{1,2,3}])]}]

Total@Table[(B//(Subscript[m, 3,2->2])//(Subscript[m, 2,1->1]))==(B//(Subscript[m, 2,1->1])//(Subscript[m, 3,1->1])),{B,(Subscript[Basis, 3])[(Subscript[𝕆, AR,{x,y},{1,2,3}])]}]

lhs=(Subscript[𝕆, AR,{x,y},{1}])[(Subscript[𝒜, 0])[Sum[(Subscript[AW, 1])@@Table[x,k]/k!,{k,0,4}]//FA[x->x+y]]]

(Subscript[AWExp, d_])[ℒ_]:=Module[{t=AW[]},
AW[]+Sum[t=Expand[t**ℒ/k]/.a_AW/;Length[a]>d:>0,{k,d}]
]

rhs1=(Subscript[AWExp, 4])[Plus@@ι[Ad[F][X]]@{4}]/.AW->(Subscript[AW, 1])

rhs2=(Subscript[AWExp, 4])[Plus@@ι[Ad[G][Y]]@{4}]/.AW->(Subscript[AW, 2])

(Expand[rhs1*rhs2]//(Subscript[m, 1,2->1]))/.(Subscript[AW, 1])[w___]/;Length@{w}>4:>0