# Efficiently removing elements from list of permutations

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!

• How large of $n$ and $m$ are you after. I have your 5,3 case down to a couple of seconds.
– ciao
Jul 16, 2020 at 21:25
• On the order of n=10, though I realise this is unlikely :) Jul 16, 2020 at 21:31
• Can you provide more details on precisely what this is for, that is, is this just some programming exercise, is there some combinatorial interpretation you're after in the results, etc. I fear there might be an XY problem unfolding here, and I'm hesitant to go down a path that may be sub-optimal (that is, there may be a way to generate the results vs pruning them, or there may be a more direct route to the desired end result).
– ciao
Jul 17, 2020 at 0:58

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.