Permutation avoidance function

It is common for me to see if a permutation of 1,2,...,n, avoids some fixed permutation pattern. For example, the permutation [1,4,2,3,5] contains the pattern 1,3,2, as the elements [1,4,3] appear in the same relative order. For example, a function which checks if the input permutation contains the pattern 213 can be coded easily as this:

Is213AvoidingQ[p_List] := !MatchQ[p, {___, a_, ___, b_, ___, c_, ___} /; c > a > b];


Now, given a permutation pi, I want to create a function, which returns true, precisely when the input avoids pi. The idea I have is to generalize the above code, and I got the following:

IsPermutationAvoidingFunction[pi_List] :=
Module[{getVar, getBlankVar, ff, n, c, var, pattern, cond},
getVar[i_] := ToExpression@StringJoin["a", ToString@i];
getBlankVar[i_] := ToExpression@StringJoin["a", ToString@i, "_"];
n = Max@pi;
var = Table[getBlankVar[i], {i, n}];
pattern = Evaluate[Flatten[{___, Riffle[var, ___], ___}]];
cond = Table[getVar[Ordering[pi][[n + 1 - i]]], {i, n}];
cond = Greater @@ cond;
cond = Condition[pattern, Evaluate@cond];
ReleaseHold[ff[{p},
! Hold[MatchQ][p, cond]
] /. ff -> Function]
];


Now, IsPermutationAvoidingFunction[{2,1,3}] and Is213AvoidingQ do the same thing, great! But can the code above be made nicer? At it is now, it looks horrible.

I think another way of phrasing your permutation avoidance problem is

Does there exist no sublist, whose elements has the same ordering as pi?

which can be straightforwardly implemented using Ordering

IsPermutationAvoidingFunctionNew[pi_?PermutationListQ]:=
Function[p,!MemberQ[Ordering /@ Subsets[Ordering@p, {Length @ pi}], pi]]


This should behave the same as your function

func1=IsPermutationAvoidingFunction[{2,1,4,3}]
func2=IsPermutationAvoidingFunctionNew[{2,1,4,3}]

And@@Table[func1[perm] === func2[perm], {perm,Permutations[Range@8]}]
(* True *)


and has approximately the same runtime

RepeatedTiming[func1/@Permutations@Range@9;]
RepeatedTiming[func2/@Permutations@Range@9;]
(* {23.5909, Null} *)
(* {23.2453, Null} *)


(at least for this example)

• I agree that this brute-force approach is the same, but I wonder if the MatchQ might be quicker sometimes (certainly, one can do some shortcuts, say if i and j are not in the right order, then no need to check any of the {i,j,k} subsets...). But MatchQ is perhaps not this smart... Nov 29 '21 at 17:17
• FYI, if we use {5, 3, 1, 4, 2} as the permutation pattern, then the two functions are not equivalent And @@ Table[func1[perm] === func2[perm], {perm, Permutations[Range@7]}] gives False. Likely @Per Alexandrsson algorithm is in error? Nov 30 '21 at 15:27
• The code by Haussdorff has a bug. There is an 'ordering' missing, and should be: IsPermutationAvoidingFunctionNew[pi_?PermutationListQ]:= Function@@HoldComplete[p,!MemberQ[Ordering /@ Subsets[Ordering@p, {Length @ pi}], pi]] Dec 1 '21 at 8:42
• @PerAlexandersson Whoops, thanks, I fixed it. Dec 1 '21 at 18:00

Regarding "can the code above be made nicer", perhaps:

ClearAll[toCondition, avoidsQ]

toCondition = Module[{v = Table[Unique[], Length @ #]},
Condition[Riffle[Pattern[#, _] & /@ v, ___, {1, -1, 2}], #] &[Less @@ Permute[v, #]]]&

avoidsQ[perm_] := Not @* MatchQ[toCondition @ perm];

(* or avoidsQ[perm_] := MatchQ[Except @ toCondition @ perm]; *)


Examples:

toCondition[{2, 1, 3}]

 {___, $$21_, ___,$$22_, ___, $$23_, ___} /;$$22 < $$21 <$$23

toCondition[{2, 4, 1, 3}]

 {___, $$25_, ___,$$26_, ___, $$27_, ___,$$28_, ___} /; $$27 <$$25 < $$28 <$$26


avoidsQ gives the same result as OP's IsPermutationAvoidingFunction and is slightly faster:

p = {2, 1, 3};

res1 = avoidsQ[p] /@ Permutations[Range @ 8]; // RepeatedTiming // First

0.70

res2 = IsPermutationAvoidingFunction[p] /@ Permutations[Range @ 8]; //
RepeatedTiming // First

0.797

res1 == res2

True


For large input lists both avoidsQ and IsPermutationAvoidingFunction are much faster than notPermPatternMatch from MikeY's post and IsPermutationAvoidingFunctionNew from Hausdorff's post:

SeedRandom[1]
rs = RandomSample @ Range @ 200;
pi = {3, 2, 1, 4};

avoidsQ[pi] @ rs // RepeatedTiming

 {0.034, False}

IsPermutationAvoidingFunction[pi] @ rs // RepeatedTiming

 {0.036, False}

notPermPatternMatch[rs, pi] // RepeatedTiming

 {5.03, False}

IsPermutationAvoidingFunctionNew[pi] @ rs // RepeatedTiming

 {59.8, False}

• Ah, so there is indeed some value in using the built-in MatchQ then? Interesting! Dec 1 '21 at 11:00
• Nice! So often I find using patterns slows down algorithms. Dec 1 '21 at 17:40
• Wow, and even in the case where there aren't any matches it is pretty fast. For example, avoidsQ[{3, 2, 1, 4}] @ Reverse @ Range @ 200 returns True in just 95 seconds Dec 1 '21 at 18:32
• @MikeY, Hausdorff, I too am surprised. (Perhaps we shouldn't be since pattern matching is a crucial piece of Mathematica smarts)
– kglr
Dec 2 '21 at 4:23
• My guess is that these types of patterns are compiled/transformed into some finite state machine or similar, and optimized fairly aggressively (e.g., similar to regex). Dec 2 '21 at 6:36

Added for posterity, as it's a little slower result than @Hausdorrff's.

The idea was to permute each subset as per $$pi$$ and see if it is ordered.

 makePermAvoidingFunk[pi_List] :=
Function @@ HoldComplete[perm,Nor@@Map[OrderedQ@#[[pi]] &, Subsets[perm, {Length@pi}]]]


EDIT

If the perm is much larger in size than the pattern, then it makes sense to break it up and not create all of the subsets. Here's a function that takes the perm and the pattern.

 nppm[perms_, pat_] := ! MemberQ[Ordering /@ perms, pat];


and

 notPermPatternMatch[perm_?PermutationListQ, pat_?PermutationListQ] :=
Module[
{
lenPat = Length@pat,
parts,
partSize = 1000 (* how big of a bite to take each iteration *)
},

parts = Partition[Range[Binomial[Length@perm, Length@pat]], UpTo@partSize];
Catch[
Scan[If[nppm[Subsets[perm, {lenPat}, {First@#, Last@#}], pat] ==False, Throw[False]] &, parts];
True
] (* end catch *)
];


Test

 pi = {3, 2, 1, 4};
func2 = IsPermutationAvoidingFunctionNew[pi];

rs = RandomSample@Range@200;
func2@rs // Timing
(*  {26.7344, False} *)

notPermPatternMatch[rs, pi] // Timing
(*  {3.20313, False}  *)