# Improve quality of my code to generating list

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[], 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} 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)\}$.

• 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. – N.J.Evans Dec 5 '17 at 19:20
• @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. – QuantumDot Dec 5 '17 at 19:28
• 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. – N.J.Evans Dec 5 '17 at 20:12

## 2 Answers

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]
myF[Range] // 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]]]


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

• 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. – QuantumDot Dec 5 '17 at 21:47