Pensieve header: Counting virtual pure braids: Cartesian product diagrams immediately serialized. May contain a Mathematica- or an OS- or a Hardware- induced crash in the computation of CountVPB[5,{4,6}].

An ERO is an Equivalence Relation Object, as in EquivalenceRelations.nb.

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] ]

VPB[n_,gs_List]:=1+Sum[(((2n(n-1)))^s),{s,0,Length[gs]-1}]+FromDigits[gs//.{(Subscript[σ, i_,j_]):>(n-1)(i-1)+If[j<i,j-1,j-2], (Subscript[(OverBar[σ]), i_,j_]):>n(n-1)+(Subscript[σ, i,j])},2n(n-1)];

VPB[n_,c_Integer]:=Module[{c1,cc,r=0,s,i,j,d},
c1=cc=c-1;
While[(c1=cc-(((2n(n-1)))^r))≥0,cc=c1;++r];
Table[
{r,i,j}=1+IntegerDigits[d,MixedRadix[{2,n,n-1}],3];
If[j≥i,++j];
If[r==1,(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])],
{d,IntegerDigits[cc,2n(n-1),r]}
]]

VPB[3,#]&/@Range[50]

Range[50]===(VPB[3,#]&/@(VPB[3,#]&/@Range[50]))

CountVPB[n_,m_]:=CountVPB[n,{m,m}];
CountVPB[n_,{m1_,m2_}]:=Module[{σ,gens,dc,d2n,s,VPB,T,ij,ijk,ijkl,i,j,k,l,perm},
{(Subscript[σ, i_,j_]):=(n-1)(i-1)+If[j<i,j-1,j-2], (Subscript[(OverBar[σ]), i_,j_]):=n(n-1)+(Subscript[σ, i,j])};
gens=Range[2n(n-1)]-1;
dc[m_]:=dc[m]=Sum[(((2n(n-1)))^s),{s,0,m}];
Print[dc/@{m1,m2}," diagrams..."];
EROMake[$er,dc[m2]];
VPB[_,gs_List]:=1+dc[Length[gs]-1]+FromDigits[gs,2n(n-1)];
T[b1_,b2_]:=EROAdjoin[$er,b1\[UndirectedEdge]b2];
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,dc[m1]],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[2,5]

Timing@CountVPB[2,6]

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]

Timing@CountVPB[5,4]

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

VPB[5,68721573889]

Timing@CountVPB[6,1]

Timing@CountVPB[6,2]

Timing@CountVPB[6,3]