Permutation Pattern

Author

Eric W. Weisstein
March 11, 2009

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Combinatorics/PermutationPattern.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/PermutationPattern.html.

©2009 Wolfram Research, Inc. except for portions noted otherwise

Time Tests

Original Version

ContainsQ[l_List,pat_List]:=OrderIsomorphicQ[#,pat]&/@Or@@KSubsets[l,Length[pat]]

p=Permutations[Range[4]];
Do[Print[{p[[i]],Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{2,3,1}]
&&AvoidsQ[#,p[[i]]]&
],{n,7}]}//Timing],{i,Length[p]}]

Next subset version

ContainsQ[l_List,pat_List]:=Module[{ksub,ksub0},
If[Length[pat]>Length[l],Return[False]];
ksub=ksub0=Take[l,Length[pat]];
If[OrderIsomorphicQ[ksub,pat],Return[True]];
While[(ksub=NextKSubset[l,ksub])≠ksub0,
If[OrderIsomorphicQ[ksub,pat],Return[True]]
];
Return[False];
]

p=Permutations[Range[4]];
Do[Print[{p[[i]],Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{2,3,1}]
&&AvoidsQ[#,p[[i]]]&
],{n,7}]}//Timing],{i,Length[p]}]

Union before ORing version

ContainsQ[l_List,pat_List]:=OrderIsomorphicQ[#,pat]&/@Or@@Union[KSubsets[l,Length[pat]]]

p=Permutations[Range[4]];
Do[Print[{p[[i]],Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{2,3,1}]
&&AvoidsQ[#,p[[i]]]&
],{n,7}]}//Timing],{i,Length[p]}]

Permutations Containing Length 1 Patterns

Patterns[7,{1}]

Permutations Containing Length 2 Patterns

Select[Permutations[Range[3]],PermutationMatchQ[#,{1,2}]&]

Patterns[9,{1,2}]

Patterns[5,{1,2}]

Patterns[5,{2,1}]

Permutations Containing Length 3 Patterns

Table[n!-Binomial[2n,n]/(n+1),{n,8}]

FullSimplify[n!-Binomial[2n,n]/(n+1)]

Permutations[Range[3]][[1]]

{#,Patterns[7,#]}&/@{Permutations[Range[3]][[2]]}

ColumnForm[{#,Patterns[6,#]}&/@Permutations[Range[3]]]

Table[Binomial[2n,n]/(n+1),{n,6}]

p=Permutations[Range[3]];
Table[{p[[k]],Table[Length[Select[Permutations[Range[n]],AvoidsQ[#,p[[k]]]&]],{n,6}]}//Timing,{k,6}]//ColumnForm

Length 4

ColumnForm[{#,Patterns[6,#]}&/@Permutations[Range[4]]]

p={#,Patterns[7,#]}&/@Permutations[Range[4]];//Timing

(#[[1,2]]->#[[All,1]])&/@GatherBy[p,Last]//Column

p={#,Patterns[8,#]}&/@Permutations[Range[4]];//Timing

(#[[1,2]]->#[[All,1]])&/@GatherBy[p,Last]//Column

Patterns[7,{1,2,3,4}]//Timing

Patterns[8,{1,2,3,4}]//Timing

Patterns[7,{1,3,4,2}]//Timing

Patterns[8,{1,3,4,2}]//Timing

ColumnForm[{#,Patterns[7,#]}&/@Permutations[Range[4]]]

Avoiding (123,132)

Solve[{r1+r2+r3+r4==n,
n-1==3,
n-(r1)-2==4,
n-(r1+r2)-3==2,
n-(r1+r2+r3)==1},{r1,r2,r3,r4}]

f[d_]:=(1-x)/(1-2x+x^d)
g[d_]:=x^d/(1-2x+x^d)

Cancel[Simplify[Det[{
{f[r1],-g[r1],0,0},
{f[r2],1,-g[r2],0},
{f[r3],0,1,-g[r3]},
{f[r4],0,0,1}}]/.{r4->1,r3->4,r2->1,r1->-2}]]

Avoiding (123, 132, 3214)

Table[Tribonacci[n],{n,10}]

Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{1,3,2}]
&&AvoidsQ[#,{3,2,1,4}]&
],{n,7}]//Timing

Avoiding (123, 132, 3241)

Table[Fibonacci[n+2]-1,{n,10}]

Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{1,3,2}]
&&AvoidsQ[#,{3,2,4,1}]&
],{n,7}]//Timing

Avoiding (123, 132, 3412)

Table[Binomial[n,2]+1,{n,10}]

Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{1,3,2}]
&&AvoidsQ[#,{3,4,1,2}]&
],{n,7}]//Timing

Avoiding (123, 132, 3421)

Table[3n-5,{n,7}]

Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{3,4,2,1}]
&&AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{1,3,2}]&
],{n,7}]//Timing

Do the biggest avoidance "last"

Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{1,3,2}]
&&AvoidsQ[#,{3,4,2,1}]&
],{n,7}]//Timing

Avoiding 123, 231

Avoiding 123, 231, 4312

Table[2n-2,{n,10}]

p={{4,3,1,2},{1,4,3,2},{2,1,4,3},{3,2,1,4}};
Table[{p[[i]],Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{2,3,1}]
&&AvoidsQ[#,p[[i]]]&
],{n,6}]}//Timing,{i,Length[p]}]//ColumnForm

Avoiding 123, 231, xxxx

p=Permutations[Range[4]];
Table[{p[[i]],Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{2,3,1}]
&&AvoidsQ[#,p[[i]]]&
],{n,7}]}//Timing,{i,Length[p]}]//ColumnForm

p=Permutations[Range[4]];
Do[Print[{p[[i]],Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{2,3,1}]
&&AvoidsQ[#,p[[i]]]&
],{n,8}]}//Timing],{i,Length[p]}]

p=Permutations[Range[4]];
Do[Print[{p[[i]],Length/@Table[Select[Permutations[Range[n]],
AvoidsQ[#,{1,2,3}]
&&AvoidsQ[#,{2,3,1}]
&&AvoidsQ[#,p[[i]]]&
],{n,8}]}//Timing],{i,Length[p]}]

OES

<<Utilities`EISFormat`

FormatSequence[{1,17,207,2279,24553},
158005,4,
SequenceName->"Numbers of pattern-matching permutations of (1234) for the permutations of {1, 2, ..., n} on n = 4, 5, 6, ... elements.",
html["Permutation Pattern"]
]

FormatSequence[{1,17,208,2300,24835},
158006,4,
SequenceName->"Numbers of pattern-matching permutations of (1342) for the permutations of {1, 2, ..., n} on n = 4, 5, 6, ... elements.",
html["Permutation Pattern"]
]

FormatSequence[{1,17,207,2278,24527},
158009,4,
SequenceName->"Numbers of pattern-matching permutations of (1324) for the permutations of {1, 2, ..., n} on n = 4, 5, 6, ... elements.",
html["Permutation Pattern"]
]