7

Hope there is a solution besides the tedious generation of nested loops. (Trying to avoid reinventing the wheel.)

Here is an example with $N = 3$ objects. There are $13$ needed orderings (first {} means first place, second {} means second place, ...):

1. {a}, {b}, {c}
2. {a}, {c}, {b}
3. {a}, {b, c}
4. {b}, {a}, {c}
5. {b}, {c}, {a}
6. {b}, {a, c}
7. {c}, {a}, {b}
8. {c}, {b}, {a}
9. {c}, {a, b}
10. {a, b}, {c}
11. {a, c}, {b}
12. {b, c}, {a}
13. {a, b, c}

How can I get all such orderings for a given $N$?

UPD: I also wonder how to get same orderings in binary relations notation, i.e., considering orderings as sets of ordered pairs (also neglecting here such pairs as $(a,a)$, $(b,b)$, ... since they don't make further difference). I found out that this notation is much easier way to further operating with rankings in Mathematica. Here are the above $13$ orderings in new notation:

1. {(a,b), (a,c), (b,c)}
2. {(a,c), (a,b), (c,b)}
3. {(a,b), (a,c), (b,c) (c,b)}
4. {(b,a), (b,c), (a,c)}
5. {(b,c), (b,a), (c,a)}
6. {(b,a), (b,c), (a,c), (c,a)}
7. {(c,a), (c,b), (a,b)}
8. {(c,b), (c,a), (b,a)}
9. {(c,a), (c,b), (a,b), (b,a)}
10. {(a,b), (b,a), (a,c), (b,c)}
11. {(a,c), (c,a), (a,b), (c,b)}
12. {(b,c), (c,b), (b,a), (c,a)}
13. {(a,b), (b,a), (a,c), (c,a), (b,c), (c,b)}
Svend Tveskæg
  • 425
  • 5
  • 14
aeiklmkv
  • 177
  • 6

1 Answers1

14

You can use ReplaceList with a helper function which has the Orderless attribute:

ClearAll[f]; SetAttributes[f, Orderless];

ReplaceList[f[a, b, c], f[a___, b___, c___] :> {{a}, {b}, {c}}] //
   DeleteCases[#, {}, -1] & // Union // Column

enter image description here

The DeleteCases and Union are required because the output from ReplaceList includes the empty list {} as a distinct entity.

For an arbitrary input list the pattern has to be constructed with the appropriate number of arguments:

orderings[x_] := Module[{f},
  SetAttributes[f, Orderless];
  ReplaceList[f @@ x, With[{s = Table[Unique[], {Length@x}]},
      Pattern[#, ___] & /@ f @@ s :> Evaluate[Thread[{s}]]]] //
    DeleteCases[#, {}, -1] & // Union]

Style[orderings[{1, 2, 3, 4}], Small]

enter image description here

Simon Woods
  • 84,945
  • 8
  • 175
  • 324
  • My PC freezes for N=10 objects. (I know, there are over 10^8 orderings.) Is it possible somehow to manage with them? – aeiklmkv Nov 20 '13 at 11:15
  • 1
    @aeiklmkv, with N=10 the whole list would require something like 100GB of storage. I'm not sure what you want to do with the orderings, but I think you will need an entirely different approach, e.g. generating them one-by-one or in batches, then discarding. – Simon Woods Nov 20 '13 at 12:30
  • I have updated the question, wondering other notation. Also, 100GB is not problem, but speed/time is problem (my PC just freezes). Nevertheless, I will try to generate orderings one-by-one in batches. – aeiklmkv Nov 25 '13 at 09:39