4
$\begingroup$

I need to write a function that constructs a set of certain permutations of a list of an even number of entries. Below, you can see my program that gives the correct result.

myF[_[]] = 1;
myF[list_] := With[{n = Length[list]},
  Table[{br[list[[1]], list[[i]]] myF[Rest[Drop[list, {i}]]]}
  , {i, 2, n}]];

Then this is what I need:

(myF[{a, b, c, d, e, f}] // Expand // Flatten) /. {Times -> List, br -> Sequence}

enter image description here

Unfortunately, I don't like the quality of my code. I don't like how I have to create symbols like br, or use procedural function like Table, or all the post-processing I have to do to finally get it in the form that I need.

Would someone kindly provide a suggestion to improve my code? One that rewrites this from scratch in functional style would be ideal!


Mathematical note:

The set of permutations that myF constructs is as follows: Group entires of each permutation pairwise as shown by parentheses: $\{\{(a,b),(c,d),(e,f)\}$, ...

Then I need the permutations which are neither related by interchange of any pair e.g. $\{\{(c,d), (a,b) ,(e,f)\}$, nor ones related by interchange of entries within a pair e.g. $\{\{(b,a), (c,d) ,(e,f)\}$.

$\endgroup$
  • $\begingroup$ In the list you generated all the entries start with a but this doesn't seem to be a consequence of the two rules you've stated. e.g. {c,b,a,d,e,f} should be included. $\endgroup$ – N.J.Evans Dec 5 '17 at 19:20
  • 1
    $\begingroup$ @N.J.Evans {c,b,a,d,e,f} is equivalent to {a,d,c,b,e,f} by exchanging the first pair with the second, and to {a,d,b,c,e,f} by exchanging the entries within the middle pair. $\endgroup$ – QuantumDot Dec 5 '17 at 19:28
  • $\begingroup$ Oops. Got it. Flatten /@ DeleteDuplicates[ Partition[#, 2] & /@ Permutations[{a, b, c, d, e, f}], Equal @@ Map[Sort, {#1, #2}, 2] & ] Is a brute force method. $\endgroup$ – N.J.Evans Dec 5 '17 at 20:12
2
$\begingroup$

Maybe this way

myF[L_] := Fold[With[{m = #2}, Join @@ (MapThread[{Reverse[Subsets[#, {m - 1}, -m]],
                  Join[ConstantArray[#2, m], Subsets[#, {2}, m], 2]} &, #] & /@ #)] &,
                             {{{L}, {{}}}}, Range[Length[L] - 1, 1, -2]][[All, 2, 1]]


myF[Range[6]]
myF[Range[14]] // Length // AbsoluteTiming
 {{1, 2, 3, 4, 5, 6}, {1, 2, 3, 5, 4, 6}, {1, 2, 3, 6, 4, 5}, {1, 3, 2, 4, 5, 6},
  {1, 3, 2, 5, 4, 6}, {1, 3, 2, 6, 4, 5}, {1, 4, 2, 3, 5, 6}, {1, 4, 2, 5, 3, 6},
  {1, 4, 2, 6, 3, 5}, {1, 5, 2, 3, 4, 6}, {1, 5, 2, 4, 3, 6}, {1, 5, 2, 6, 3, 4},
  {1, 6, 2, 3, 4, 5}, {1, 6, 2, 4, 3, 5}, {1, 6, 2, 5, 3, 4}}

{2.0315701, 135135}

Replacing the last (and slowest) Fold iteration by Flatten speeds up the function by a factor 2.

myF[L_] := With[{perms = {{}}, remain = {L}},
     Flatten[#, {{1, 3}, {2, 4}}] &@
        Fold[With[{m = #2}, Join @@ (
            MapThread[{
                  Join[ConstantArray[#, m], Subsets[#2, {2}, m], 2],  (* perms *)
                  Reverse[Subsets[#2, {m - 1}, -m]]} &,               (* remain *)
             #] & /@ #)] &,
         {{perms, remain}}, Range[Length[L] - 1, 3, -2]]]
$\endgroup$
1
$\begingroup$

A brute force method that relies on generating all permutations then deleting those that don't meet your criteria can be written as:

Flatten/@DeleteDuplicates[
    Partition[#,2]&/@Permutations[{a,b,c,d,e,f}],
    Equal @@ Map[Sort, {#1, #2}, 2] &
]

Partition is applied to the permutations just because it's easier to do it here or you start getting nested slots and you either need to write auxiliary functions, or use Function. The only bit that requires much thought beyond this is the test used to determine equality of two lists. It sorts each pair independently, then sorts the pairs based on their first element and compares the two elements. Equal @@ Map[Sort, {#1, #2}, 2] & is compact way to write something like:

yourTest[x_,y_]:=SortBy[Sort/@x,First]==SortBy[Sort/@y,First]

Output is:

{{a, b, c, d, e, f}, {a, b, c, e, d, f}, {a, b, c, f, d, e}, 
 {a, c, b, d, e, f}, {a, c, b, e, d, f}, {a, c, b, f, d, e}, 
 {a, d, b, c, e, f}, {a, d, b, e, c, f}, {a, d, b, f, c, e}, 
 {a, e, b, c, d, f}, {a, e, b, d, c, f}, {a, e, b, f, c, d}, 
 {a, f, b, c, d, e}, {a, f, b, d, c, e}, {a, f, b, e, c, d}}
$\endgroup$
  • 1
    $\begingroup$ Thanks; I'll wait and see if people come up with more efficient methods since Permutations on large lists will make far too many needless duplicates. $\endgroup$ – QuantumDot Dec 5 '17 at 21:47

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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