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

Bases

(Subscript[Basis, d_])[(Subscript[𝕆, AR,ps_,ss_])]:=(Subscript[PP, EMBasis])[(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, d_])[(Subscript[𝕆, HR,ps_,ss_])]:=(Subscript[PP, EMBasis])[(Subscript[𝕆, HR,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[CW, (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}]
}]]

Utilities

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

(Subscript[𝕆, red_,ps_,ss_])[x_]+(Subscript[𝕆, red_,ps_,ss_])[y_]^:=(Subscript[𝕆, red,ps,ss])[x+y];
c_*(Subscript[𝕆, red_,ps_,ss_])[x_]^:=(Subscript[𝕆, red,ps,ss])[Expand[c x]];
(Subscript[𝕆, __])[0]=0;

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

AR: Reduction in A

AR[0]=0;
AR[(Subscript[𝒜, 0])[A_]]:=(Subscript[𝒜, 0])[A];
AR[(Subscript[𝒜, c[s_]])[A_]]:=(Subscript[PP, EMAR])@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_]]:=(Subscript[PP, EMAR])@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: Reduction in the H Quotient

HR[0]=0;
HR[(Subscript[𝒜, 0])[A_]]:=(Subscript[𝒜, 0])[A];
HR[(Subscript[𝒜, c[s_]])[A_]]:=(Subscript[PP, EMHR])@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[PP, EMHR])@(Subscript[𝒜, c[s1,s2]])[A//(Subscript[m, s1,(OverBar[s2])->s1])//(Subscript[m, s2,(OverBar[s1])->s2])//(Subscript[η, (OverBar[s1])])//(Subscript[η, (OverBar[s2])])];

Reordering strands

(Subscript[𝕆, ss_])[(Subscript[𝕆, red_,ps_,s0s_])[y_]]/;FreeQ[y,(Subscript[𝒜, 0])]:= (Subscript[PP, 𝕆])@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_.]]:= (Subscript[PP, 𝕆])@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[𝔻[p], s1->s1,(OverBar[s1])])//(Subscript[𝔻[p], s2->s2,(OverBar[s2])])//(Subscript[m, s1,u1->s1])//(Subscript[m, u2,(OverBar[s1])->(OverBar[s1])])]],
{p,ps}
]
],
{i,Length[ss]-1},{j,i+1,Length@ss}
]
]]];
𝕆[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[𝕆, Sort[ss]])@(Subscript[𝕆, red,ps,ss])[ℰ]

Pole Renaming

(Subscript[pσ, x_->y_])[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[PP, EMpσ])@(Subscript[𝕆, red,Replace[x->y]/@ps,ss])[ℰ//FA[x->y]]

Strand Renaming

(Subscript[sσ, i_->j_])[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[PP, EMsσ])@(Subscript[𝕆, red,ps,Replace[i->j]/@ss])[ℰ/.(Subscript[𝒜, a_])[A_]:>((Subscript[𝒜, Replace[i->j]/@a])[A//(Subscript[σ, i->j])//(Subscript[σ, (OverBar[i])->(OverBar[j])])//(Subscript[σ, (OverTilde[i])->(OverTilde[j])])])]

Strand Multiplication

(Subscript[sm, __])[0]=0;
(Subscript[𝕆, red_,ps_,ss_])[ℰ_]//(Subscript[sm, i_,j_->k_]):=(Subscript[PP, EMsm])@𝕆@(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])]
}]

The Unit for Poles

(Subscript[pη, x_])[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[𝕆, red,ps⋃{x},ss])[ℰ]

The Unit for Strands

(Subscript[sη, i_])[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[𝕆, red,ps,ss~Join~{i}])[ℰ/.(Subscript[𝒜, a_])[A_]:>(Subscript[𝒜, a])[A//(Subscript[η, i])]]

Strand Doubling

(Subscript[sΔ, i_->j_,k_])[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[PP, EMsΔ])@Module[{u1,u2},
𝕆@(Subscript[𝕆, red,ps,Replace[i->Sequence[j,k]]/@ss])[ℰ/.{
(Subscript[𝒜, 0])[A_]:> (Subscript[𝒜, 0])[A//(Subscript[Δ, i->j,k])]+(Subscript[𝒜, c[j,k]])[Sum[Expand[A((Subscript[AW, u1])[p](Subscript[AW, u2])[]-(Subscript[AW, u1])[](Subscript[AW, u2])[p])]//(Subscript[𝔻[p], i->i,(OverBar[i])])//(Subscript[𝔻[p], (OverBar[i])->(OverBar[i]),(OverTilde[i])])//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[Δ, (OverTilde[i])->(OverTilde[j]),(OverTilde[k])])//(Subscript[m, j,(OverBar[j])->j])//(Subscript[σ, (OverTilde[j])->(OverBar[j])])//(Subscript[m, (OverBar[k]),(OverTilde[k])->(OverBar[k])])//(Subscript[m, j,u1->j])//(Subscript[m, u2,(OverBar[j])->(OverBar[j])]),{p,ps}]],
(Subscript[𝒜, c[x_,i]])[A_]:>(Subscript[𝒜, c[x,j]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[m, k,(OverBar[k])->k])]+(Subscript[𝒜, c[x,k]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[m, j,(OverBar[j])->j])],
(Subscript[𝒜, c[i,y_]])[A_]:>(Subscript[𝒜, c[j,y]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[m, k,(OverBar[k])->k])]+(Subscript[𝒜, c[k,y]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[m, j,(OverBar[j])->j])],
(Subscript[𝒜, c[i]])[A_]:>(Subscript[𝒜, c[j]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[Δ, (OverTilde[i])->(OverTilde[j]),(OverTilde[k])])//(Subscript[m, k,(OverBar[k])->k])//(Subscript[m, k,(OverTilde[k])->k])]+(Subscript[𝒜, c[k]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[Δ, (OverTilde[i])->(OverTilde[j]),(OverTilde[k])])//(Subscript[m, j,(OverBar[j])->j])//(Subscript[m, j,(OverTilde[j])->j])]+(Subscript[𝒜, c[j,k]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[Δ, (OverTilde[i])->(OverTilde[j]),(OverTilde[k])])//(Subscript[m, (OverBar[j]),(OverTilde[j])->(OverBar[j])])//(Subscript[m, k,(OverBar[k])->k])//(Subscript[σ, (OverTilde[k])->(OverBar[k])])]+(Subscript[𝒜, c[j,k]])[A//(Subscript[Δ, i->j,k])//(Subscript[Δ, (OverBar[i])->(OverBar[j]),(OverBar[k])])//(Subscript[Δ, (OverTilde[i])->(OverTilde[j]),(OverTilde[k])])//(Subscript[m, (OverBar[k]),(OverTilde[k])->(OverBar[k])])//(Subscript[m, j,(OverBar[j])->j])//(Subscript[σ, (OverTilde[j])->(OverBar[j])])],
(Subscript[𝒜, a_])[A_]:>(Subscript[𝒜, a])[A//(Subscript[Δ, i->j,k])]
}]
]

Pole Doubling

(Subscript[pΔ, x_->y_,z_])[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[PP, EMpΔ])@(Subscript[𝕆, red,Replace[x->Sequence[y,z]]/@ps,ss])[ℰ/.(Subscript[𝒜, a_])[A_]:>(Subscript[𝒜, a])[A//FA[x->y+z]]]

Pole to strand conversion

(Subscript[p2s, x_->i_])[(Subscript[𝕆, red_,ps_,ss_])[ℰ_]]:=(Subscript[PP, EMp2s])@CF@(Subscript[𝕆, red,DeleteCases[ps,x],{i}~Join~ss])[ℰ/.{
(Subscript[𝒜, 0])[A_]:>(Subscript[𝒜, 0])[A//FA[x->0]//(Subscript[η, i])]+Sum[
(Subscript[𝒜, c[i,s]])[A//(Subscript[𝔻[x], s->s,(OverBar[s])])//FA[x->0]//(Subscript[η, i])//(Subscript[η, (OverBar[i])])],
{s,ss}],
(Subscript[𝒜, c_])[A_]:>(Subscript[𝒜, c])[A//FA[x->0]]
}]

Exterior Multiplication

(Subscript[EM, d_])[(Subscript[𝕆, red_,ps1_,ss1_])[ℰ1_],(Subscript[𝕆, red_,ps2_,ss2_])[ℰ2_]]/;ss1⋂ss2==={}:=(Subscript[PP, EMEM])@(Subscript[𝕆, red,ps1⋃ps2,ss1~Join~ss2])[Expand[ℰ1*ℰ2]/.{
(Subscript[𝒜, 0])[A1_](Subscript[𝒜, 0])[A2_]:>(Subscript[𝒜, 0])[(Subscript[EM, d])[A1,A2]],
(Subscript[𝒜, 0])[A1_](Subscript[𝒜, c_])[A2_]:>(Subscript[𝒜, c])[(Subscript[EM, d-1])[A1,A2]],
(Subscript[𝒜, c1_])[_](Subscript[𝒜, c2_])[_]->0
}
]

Interior Multiplication

(Subscript[IM, d_])[(Subscript[𝕆, red_,ps_,ss1_])[ℰ1_],(Subscript[𝕆, red_,ps_,ss2_])[ℰ2_]]/;Sort[ss1]===Sort[ss2]:=(Subscript[PP, EMIM])@Module[{ℰ,ν},
ℰ=(Subscript[𝕆, red,ps,ss1])[ℰ2];
Do[ℰ=ℰ//(Subscript[sσ, s->ν[s]]),{s,ss2}];
ℰ=(Subscript[EM, d])[(Subscript[𝕆, red,ps,ss1])[ℰ1],ℰ];
Do[ℰ=ℰ//(Subscript[sm, s,ν[s]->s]),{s,ss1}];
ℰ
];
(Subscript[IM, d_])[ℰ1_,ℰ2_,ℰ3__]:=(Subscript[IM, d])[(Subscript[IM, d])[ℰ1,ℰ2],ℰ3]