5
$\begingroup$

I have a pattern defined using variables: {a,b,a,b} and I want to generate all possible instances of this list where each variable ranges from 1 to n, and each variable is assumed to be unique.

One way to do this is:

n = 2;
Cases[Flatten[
  Table[If[a != b, {a, b, a, b}, {}], {a, 1, n}, {b, 1, n}], 1], 
 Except[{}]]
(*{{1, 2, 1, 2}, {2, 1, 2, 1}} *)

But I have a large list of patterns and I don't want to manually create this table for each one. For example: patterns={{a,b,a,c},{a,a,a,b},{a,b,c,d},{a,b,c,c}}

$\endgroup$
0

6 Answers 6

2
$\begingroup$

A replacement-rule-based approach:

patterns = {{a, b, a, c}, {a, a, a, b}, {a, b, c, d}, {a, b, c, c}};
Module[{n = 4, vars, rules},
  Table[vars = Variables@pat;
        rules = Thread[vars -> #] & /@ Permutations[Range[n]][[All, ;; Length@vars]];
        pat /. rules,
    {pat, patterns}
   ]
 ]

This will work provided n is always chosen to be at least equal to the number of distinct letters.

$\endgroup$
6
  • 1
    $\begingroup$ @David Let me know if this is what you wanted. Note that there are probably faster ways of doing things here. The easiest way to speed up this code would be to change pat /. rules to pat /. Dispatch@rules, but a non-replacement-rule-based approach will likely be faster. $\endgroup$
    – march
    Commented Sep 29, 2023 at 4:39
  • $\begingroup$ Interesting. Might be worth checking the speed relative to OP solution on a simple test case like single pattern {a, b, a, b} but n=1000 for example. $\endgroup$ Commented Sep 29, 2023 at 4:52
  • $\begingroup$ @VitaliyKaurov RepeatedTimings on this code indicate that it takes about 3 seconds for the $n=1000$ case for the pattern {a, b, a, b}. $\endgroup$
    – march
    Commented Sep 29, 2023 at 15:28
  • $\begingroup$ @march this doesn't take into account that each variable is unique. For example {a,b,a,c} shouldn't generate {1,1,1,1} because a!=b!=c $\endgroup$
    – David
    Commented Sep 29, 2023 at 17:30
  • $\begingroup$ @David Does the updated version work? $\endgroup$
    – march
    Commented Sep 29, 2023 at 18:37
1
$\begingroup$
n = 2
patterns = {{a, b, a, c}, {a, a, a, b}, {a, b, c, d}, {a, b, c, c}};
(p |-> p /. Thread[Union@p -> #] & /@ 
     Permutations[Range[n], {Length@Union@p}]) /@ patterns;
Column@%
Clear[n, patterns]

n=2

2

{}
{{1, 1, 1, 2}, {2, 2, 2, 1}}
{}
{}

n=3

3

{{1,2,1,3},{1,3,1,2},{2,1,2,3},{2,3,2,1},{3,1,3,2},{3,2,3,1}}
{{1,1,1,2},{1,1,1,3},{2,2,2,1},{2,2,2,3},{3,3,3,1},{3,3,3,2}}
{}
{{1,2,3,3},{1,3,2,2},{2,1,3,3},{2,3,1,1},{3,1,2,2},{3,2,1,1}}
$\endgroup$
1
$\begingroup$

I'll start by changing the "signature" of your problem first. Having your pattern consist of symbols, e.g. {a, b, a, b}, could be problematic as those symbols could have definitions. There are ways we can block or hold those symbols, but it's probably easier to just use strings for your patterns: "abab".

Next, we might want to provide an explicit list of possible replacement values rather than assume that it's always a range from 1 to n.

Putting that together, let's create a function with such a signature:

AllCases[vals_List, pattern_String] :=
  With[
    {listPattern = Characters[pattern]},
    With[
      {uniqueSymbols = DeleteDuplicates[listPattern]},
      ReplaceAll[listPattern, Thread[uniqueSymbols -> #]] & /@ Permutations[vals, {Length@uniqueSymbols}]]]

To demonstrate:

AllCases[Range@3, "abab"]
(* {{1,2,1,2},{1,3,1,3},{2,1,2,1},{2,3,2,3},{3,1,3,1},{3,2,3,2}} *)

You didn't indicate the size and scope of your problem space, but just so you know, this solution is about an order of magnitude slower than your table-based solution. If you need more performance, there might be follow on improvements we can try.

$\endgroup$
1
$\begingroup$

Create functions from patterns and map them on permutations:

patterns = {{a, b, a, c}, {a, a, a, b}, {a, b, c, d}, {a, b, c, c}};

ClearAll[pF, patternedPermutations]
Do[With[{arg = Pattern[#, Blank[]] & /@ Union[i], v = i}, 
  pF[i][arg] := v], {i, patterns}]

patternedPermutations[n_, p_] := Map[pF[p]] @ 
  Permutations[Range @ n, {Length @ Union @ p}]

n = 4; 
Grid[Table[{n, Column @ p, Framed @ Grid @ Transpose @ 
      patternedPermutations[n, p]},  
  {p, patterns}], Dividers -> All, Alignment -> Left]

enter image description here

n=3

enter image description here

n=2

enter image description here

$\endgroup$
0
$\begingroup$

Here's one that's only twice as slow as your Table version, but it requires more care in making sure your arguments are valid:

TemplatedPermutations[vals_List, template_List] :=
  With[
    {slotCount = CountDistinct[template]},
    With[
      {perms = Permutations[vals, {slotCount}]},
      Transpose[PermutationReplace[#, perms] & /@ template]]]

Usage:

TemplatedPermutations[Range[3], {1, 2, 1, 2}]
(* {{1,2,1,2},{1,3,1,3},{2,1,2,1},{2,3,2,3},{3,1,3,1},{3,2,3,2}} *)

The difference here is that your template/pattern needs to use integers. So, instead of {a,b,a,b}, you'd need to use {1,2,1,2}.

$\endgroup$
0
$\begingroup$

You could also just dynamically create your table expression:

TemplatePermutations[n_Integer, template : {symbols__Symbol}] :=
  With[
    {uniqueSymbols = DeleteDuplicates[template]},
    With[
      {indices = Sequence @@ Thread[{uniqueSymbols, n}],
       predicate = Unequal @@ uniqueSymbols,
       depth = Length@uniqueSymbols - 1},
      Cases[Flatten[Table[If[predicate, template, {}], indices], depth], Except[{}]]]]

Usage:

TemplatePermutations[3, {a, b, a, b}]
(* {{1,2,1,2},{1,3,1,3},{2,1,2,1},{2,3,2,3},{3,1,3,1},{3,2,3,2}} *)

[You could simplify your approach by using Nothing instead of {} and stripping the now unnecessary outer Cases.]

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.