Permutation avoidance function

Question

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.

Answer 1

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)

Answer 2

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}

Answer 3

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}  *)