Pensieve header: Counting virtual pure braids: Cartesian product diagram generation, reasonable compression.

SetAttributes[{EROMake,EROPeek,EROAdjoin}, HoldFirst];

EROMake[er_,n_Integer]:=er=Table[0,n];

EROPeek[er_,n_Integer]:= If[er[[n]]==0,n,er[[n]]=EROPeek[er,er[[n]]]];

EROAdjoin[er_,new_UndirectedEdge]:=EROAdjoin[er,new,Identity];
EROAdjoin[er_,n1_Integer\[UndirectedEdge]n2_Integer,comp_]:=Module[{m1,m2},
m1=EROPeek[er,n1]; m2=EROPeek[er,n2];
Switch[Order[{comp[m1],m1}, {comp[m2],m2}],0, m1,1, er[[m2]]=m1,-1, er[[m1]]=m2] ]

(Subscript[σ, i_,j_]):=10i+j; (Subscript[(OverBar[σ]), i_,j_]):=100+10i+j;
VPB[xs___Integer]:=FromDigits[{xs},1000];

CountVPB[n_,m_]:=CountVPB[n,{m,m}];
CountVPB[n_,{m1_,m2_}]:=Module[{gens,diags,L,d2n,er,s,T,ij,ijk,ijkl,i,j,k,l,perm},
gens=Flatten@Table[{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},{i,n},{j,DeleteCases[Range@n,i]}];
L=Length[diags=Flatten[Table[VPB[n,#]&/@Tuples[gens,s], {s,0,m1}]]];
diags=Join[diags,Flatten[Table[VPB[n,#]&/@Tuples[gens,s], {s,m1+1,m2}]]];
Print[Length@diags," diagrams..."];
d2n=Dispatch[Thread[diags->Range@Length@diags]];
EROMake[er,Length@diags];
Print["Now relations..."];
T[b1_,b2_]:=EROAdjoin[er,(b1/.d2n)\[UndirectedEdge](b2/.d2n)];
Do[{i,j}=ij; {
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},q]],VPB[n,Join[p,q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), i,j]),(Subscript[σ, i,j])},q]],VPB[n,Join[p,q]]]
},
{s,0,m2-2},{t,0,s},{p,Tuples[gens,t]},{q,Tuples[gens,s-t]},
{ij,Join@@(Permutations/@Subsets[Range[n],{2}])}
];
Do[{i,j,k}=ijk; {
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[σ, i,k]),(Subscript[σ, j,k])},q]],VPB[n,Join[p,{(Subscript[σ, j,k]),(Subscript[σ, i,k]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), j,i]),(Subscript[σ, i,k]),(Subscript[σ, j,k])},q]],VPB[n,Join[p,{(Subscript[σ, j,k]),(Subscript[σ, i,k]),(Subscript[(OverBar[σ]), j,i])},q]]],
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[σ, i,k]),(Subscript[(OverBar[σ]), k,j])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,j]),(Subscript[σ, i,k]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), k,j])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,j]),(Subscript[(OverBar[σ]), k,i]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), j,i]),(Subscript[(OverBar[σ]), k,i]),(Subscript[σ, j,k])},q]],VPB[n,Join[p,{(Subscript[σ, j,k]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), j,i])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), j,i]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), k,j])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,j]),(Subscript[(OverBar[σ]), k,i]),(Subscript[(OverBar[σ]), j,i])},q]]]
},
{s,0,m2-3},{t,0,s},{p,Tuples[gens,t]},{q,Tuples[gens,s-t]},
{ijk,Join@@(Permutations/@Subsets[Range[n],{3}])}
];
Do[{i,j,k,l}=ijkl; {
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[σ, k,l])},q]],VPB[n,Join[p,{(Subscript[σ, k,l]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), i,j]),(Subscript[σ, k,l])},q]],VPB[n,Join[p,{(Subscript[σ, k,l]),(Subscript[(OverBar[σ]), i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), k,l])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,l]),(Subscript[σ, i,j])},q]]],
T[VPB[n,Join[p,{(Subscript[(OverBar[σ]), i,j]),(Subscript[(OverBar[σ]), k,l])},q]],VPB[n,Join[p,{(Subscript[(OverBar[σ]), k,l]),(Subscript[(OverBar[σ]), i,j])},q]]]
},
{s,0,m2-2},{t,0,s},{p,Tuples[gens,t]},{q,Tuples[gens,s-t]},
{ijkl,Join@@(Permutations/@Subsets[Range[n],{4}])}
];
Count[Take[er,L],0]
]

VPB[4,(Subscript[σ, 4,1]),(Subscript[(OverBar[σ]), 2,3])]

CountVPB[2,1]

CountVPB[2,2]

Timing@CountVPB[2,3]

Timing@CountVPB[2,{3,4}]

Timing@CountVPB[2,4]

Timing@CountVPB[3,1]

Timing@CountVPB[3,2]

Timing@CountVPB[3,3]

Timing@CountVPB[3,{3,4}]

Timing@CountVPB[3,4]

Timing@CountVPB[3,{4,5}]

Timing@CountVPB[3,{4,6}]

Timing@CountVPB[3,{4,7}]

Timing@CountVPB[3,5]

Timing@CountVPB[3,{5,6}]

Timing@CountVPB[3,{5,7}]

Timing@CountVPB[4,1]

Timing@CountVPB[4,2]

Timing@CountVPB[4,3]

Timing@CountVPB[4,4]

Timing@CountVPB[4,{4,5}]

Timing@CountVPB[4,{4,6}]

Timing@CountVPB[5,1]

Timing@CountVPB[5,2]

Timing@CountVPB[5,3]