Selecting a list from a list of lists

Question

In working through Programming Paradigms Via Mathematica (A First Course) I have come across this two part question:

A permutation of length "n" is a list of the first n positive integers in some order. Example: {6,1,5,3,4,2} is a permutation of length 6. A permutation is called balanced if the sum of each consecutive pair is equal to the sum of the consecutive pair furthest away from the original pair, if we imagine the permutation written in a circle. For instance, (6,1) and (3,4) are pairs furthest away in the example above, because they are both 1 unit away from the original pair. Similarly, (2,6) and (5,3) are furthest apart. Our example is balanced because pairs furthest apart have the same sum: 6+1=3+4; 1+5 =4+2; 5+3=2+6; 3+4=6+1; 4+2=1+5; 2+6=5+3. Another way to see this is to write the consecutive sums in order (7,6,8,7,6,8) and notice that the corresponding sums are the furthest apart. Note that all of this makes sense only if the length of the permutation (n) is even.

(a) Write a function "balancedQ[ ]" which takes one argument which is a list of even length and returns True if it is balanced, False otherwise.

My answer is:

Clear[balancedQ];

balancedQ[list_List] := Module[{list2, list3, list4, list5},
   d = 1;
   If [EvenQ[Length[list]], 
    list2 := 
     Append[Partition[list, 2, 1], {First[list], Last[list]}], {d = 2,
      Goto[End]}];
   addPairs[{m_, n_}] := m + n;
   list3 := addPairs /@ list2;
   list4 := First[Partition[list3, Length[list3]/2]];
   list5 := Last[Partition[list3, Length[list3]/2]];
   While[Length[list4] > 0, 
    If[First[list4] == First[list5], {list4 = Rest[list4], 
      list5 = Rest[list5]}, {d = 2, Goto[End]}]];
   Label[End];
   If[d == 1, Print["True"], Print["False"]]];

While I am sure that it can be improved upon, it does work returning true for balancedQ[{6,1,5,3,4,2}] and false for balancedQ[{6,1,5,3,4}] (odd # of elements) and balancedQ[{6,1,5,3,2,4}] (unbalanced). The second part of the question is where I have trouble:

(b) The Mathematica function "Permutations[]" returns all possible permutations of the elements of a list. Use "Permutations[]" and your function "balancedQ[]" to find all balanced permutations of the numbers {1,2,3,4,5,6}.

In looking through the previous lessons as well as the documentation center it seems to me that Select is the correct command, and I used it as follows:

Select[Permutations[{1, 2, 3, 4, 5, 6}], balancedQ]

To my chagrin what I got in return was a column of 720 Falses (mainly) and Trues (a few). Therefore my question is, should I be looking at a different command, or is there an option that I am not seeing relative to Select?

Answer 1

The primary issue is that you were printing the result of the test function rather than returning the expression True or False as required by other functions such as Select. Instead of:

If[d == 1, Print["True"], Print["False"]]

you could write simply d === 1. === is the short form of SameQ. I used it rather than Equal because it will always return either True or False, whereas Equal may return unevaluated, e.g. Plus == 5. If your code is working it should not matter, but I consider this good practice.

Other issues I note:

1. You did not add addPairs or d to the Module declaration. You can see this by looking at the syntax highlighting in the Front End: the other (localized) symbols are green.

2. The construct {d = 2, Goto[End]} is rather unnecessary. You could use Return[False] in its place. The Goto construct may still have value if you have more complicated termination procedures.

3. Several definitions are made with SetDelayed, e.g. list3 := .... This will cause reevaluation of the code whenever this definition is referenced, slowing your program.

4. The lines list4 := ... and list5 := ... have wasteful redundancy. You would do better to write {list4, list5} = Partition[list3, Length[list3]/2] which is a simple form of destructuring.

5. Your While construct could be handled more concisely without explicit iteration. Consider: Inner[Equal, list4, list5, And]. Inner is a good choice because it allows short-circuiting.

6. The use of Append following Partition could be eliminated by using the advanced settings of Partition: Partition[list, 2, 1, 1]

7. In fact both Partition and addPairs can be replaced with a single operation:
   ListCorrelate[{1, 1}, list, 1]

8. If desired one can streamline certain parts by not using symbols (variables) but passing arguments to an anonymous Function. This makes code more compact but without descriptive symbol names also harder to read. If you follow this practice I recommend supplementing with (* comments *).

9. It can be both clearer and computationally faster to move certain tests into a separate definition line; I would do that with the test for lists of odd length.

Incorporating these ideas we get something like this:

balancedQ2[list_List] /; OddQ @ Length @ list := False

balancedQ2[list_List] :=
  Inner[Equal, ##, And] & @@
    Partition[#, Length[#]/2] & @
      ListCorrelate[{1, 1}, list, 1]

I wish to stress that this is your own algorithm boiled down by the observations above. I did not read the problem description in writing this. There may be a more efficient way to approach the problem but I wanted to demonstrate the pure process of refactoring as I believe these elements will be more applicable to your own coding than an entirely new approach.

---

After reading the problem description a couple of additional simplifications came to mind. First, we can replace the ListCorrelate operation with list + RotateLeft[list], and second, while my use of Inner is analogous to your While loop and I believe valuable to understand, in this particular case you could simply use Equal @@ to directly compare the two partitions.

balancedQ3[list_List] /; OddQ @ Length @ list := False

balancedQ3[list_List] :=
  Equal @@ Partition[list + RotateLeft[list], Length[list]/2]