Efficiently removing elements from list of permutations

Question

I'm looking for an efficient way to remove entries from a list of permutations.

I have a list of variables from which I calculate all possible permutations. I then want to remove those permutations that begin with a sequence of variables that match one from another list. The order of the variables is important.

As an example of the desired behaviour, I begin with the list $(a,b,b,c,c,c)$ and then compute all permutations, giving $((a,b,b,c,c,c),(b,a,b,c,c,c),(c,a,b,b,c,c),\ldots)$, and so on. I have a second list of the form $((a), (b, c), (c, b, b))$. I want to remove from the list of permutations those of the form $(a,\ldots)$, $(b,c,\ldots)$ or $(c,b,b,\ldots)$.

At the moment, I'm using DeleteCases to achieve this. For the above example:

(* original list of permutations *)
original = Permutations[{a, b, b, c, c, c}];

(* list of permutations to be removed *)
remove = {{a}, {b, c}, {c, b, b}};

(* convert to pattern *)
remove = Join[#, {___}] & /@ remove;

(* remove all permutations from original that start with one of the sequences in "remove" *)
reduced = DeleteCases[original, Alternatives @@ remove];

This seems fine for small numbers of permutations, but rapidly gets out of hand. The following code can be used to generate lists of arbitrary length permutations and the sequences to be removed.

(* function to repeat variable in list *)
repeat[m_, 0] := Nothing
repeat[m_, n_Integer?Positive] := Sequence @@ ConstantArray[m, n]

(* how many times do a, b, c repeat in original permutations? *)
n = 4;
(* which starting sequences are we removing? *)
m = 2;

(* original list of permutations *)
original = Permutations[{repeat[a, n], repeat[b, n], repeat[c, n]}];

(* example list of permutations to be removed - not all of the same length in general *)
remove = Join[
   Permutations[{repeat[a, m], repeat[b, m], repeat[c, m]}], 
   Permutations[{repeat[a, m], repeat[b, m], repeat[c, m + 1]}]];

(* convert to pattern *)
remove = Join[#, {___}] & /@ remove;

(*remove all permutations from original that start with one of the sequences in "remove"*)
reduced = DeleteCases[original, Alternatives @@ remove];

For $n=4$ and $m=2$, this runs in ~0.5s. For $n=5$ and $m=3$, this balloons to ~200s.

In my real code, original is generated as above, from Permutations. The remove list is not generated from a list of permutations like in the above code - it will contain elements of length 1 to one less than the length of the elements of original.

Is there any way to speed up the removal of the matching permutations? Or is it hopeless, given how the number of permutations blows up?

Thanks!

Answer 1

repeat[m_,0]:=Nothing
repeat[m_,n_Integer?Positive]:=Sequence@@ConstantArray[m,n]
n=5;
m=3;
{a,b,c}={1,2,3};
original=Permutations[{repeat[a,n],repeat[b,n],repeat[c,n]}];

rm1=Permutations[{repeat[a,m],repeat[b,m],repeat[c,m]}];
rm2=Permutations[{repeat[a,m],repeat[b,m],repeat[c,m+1]}];
Length[ans=Pick[original,BitOr@@Table[Table[Boole@MemberQ[rm,i], 
 {i,Take[original,All,Length[rm[[1]]]]}],{rm,{rm1,rm2}}],0]]//AbsoluteTiming

Clear[a, b, c]
ans2 = ans /. {1 -> a, 2 -> b, 3 -> c}; // AbsoluteTiming

For $n=5,m=3$ it takes 5s on my machine.