8
$\begingroup$

How do I create a list of tuples with an ordering imposed on them, where each element is from a generating set? Specifically, I'm trying to create a listing of tuples $(x_1, x_2, ..., x_n)$ such that $x_1 > x_2$, $x_2 \leq x_3 \leq \cdots x_n$ where each $x_i$ is in (say) $X = \{a,b,c,d\}$. The elements of $X$ are in lexicographic order.

Code:

rank = 4;
weight = 3;

X = Range[rank]; 
bc = Tuples[X, weight];
Cases[bc, {x1_, x2_, x3_} /; x1 > x2 && x2 <= x3]

Issues 1. rank and weight are independent; they don't need to be =. 2. I'd like to say x1_, .., xrank_, but I'm not sure how to specify x_rank. Also x2 <= x3 <= ... <= xrank. (I'll loop on rank and weight, so these won't be hard-coded values.) 3. At the end, 1, 2, ..., rank should be traded for a, b, ... (whatever letter).

$\endgroup$
1
  • $\begingroup$ Considering that your tuples are of length of your list, you can try something like this,Block[{k = {a, b, c, d} /. {a -> 1, b -> 2, c -> 3, d -> 4}, ca}, {ca = Tuples[k, Length[k]]; Cases[ca, {a_, b_, c_, d_} /; a > b && b < c < d] /. {1 -> a, 2 -> b, 3 -> c, 4 -> d}}] $\endgroup$ Commented Sep 7, 2013 at 19:51

4 Answers 4

5
$\begingroup$

If I understand the question generating all Tuples and then filtering is wasteful, and will "blow up" for long sets. Since you want all but one element in canonical order I believe you should generate those, then prefix as needed to complete the sequence.

Here is a mundane loop-based way to build the tuples; I couldn't think of anything that ran faster.

tuples[rank_Integer, k_Integer] :=
  Block[{i},
    i[0] = 1;
    Flatten[
      Table @@ Join[{First /@ #}, #] &@Array[{i[#], i[# - 1], rank} &, k - 1],
      k - 2
    ]
  ] // Join @@ (Table[{i, ##}, {i, # + 1, rank}] & @@@ #) &

Example:

tuples[5, 3]
{{2, 1, 1}, {3, 1, 1}, {4, 1, 1}, {5, 1, 1}, {2, 1, 2}, {3, 1, 2}, {4, 1, 2}, {5, 1, 2},
 {2, 1, 3}, {3, 1, 3}, {4, 1, 3}, {5, 1, 3}, {2, 1, 4}, {3, 1, 4}, {4, 1, 4}, {5, 1, 4},
 {2, 1, 5}, {3, 1, 5}, {4, 1, 5}, {5, 1, 5}, {3, 2, 2}, {4, 2, 2}, {5, 2, 2}, {3, 2, 3},
 {4, 2, 3}, {5, 2, 3}, {3, 2, 4}, {4, 2, 4}, {5, 2, 4}, {3, 2, 5}, {4, 2, 5}, {5, 2, 5},
 {4, 3, 3}, {5, 3, 3}, {4, 3, 4}, {5, 3, 4}, {4, 3, 5}, {5, 3, 5}, {5, 4, 4}, {5, 4, 5}}

You can fill these tuples with arbitrary expressions like this:

x = {"a", "b", "c", "d", "e"};

x[[#]] & /@ tuples[5, 3]
{{"b", "a", "a"}, {"c", "a", "a"}, {"d", "a", "a"}, . . .
   {"e", "c", "e"}, {"e", "d", "d"}, {"e", "d", "e"}}

The function will work on values that would not work with Tuples:

tuples[12, 8] // Length

306306

Using Tuples before filtering would generate 12^8 = 429,981,696 sets.

$\endgroup$
1
$\begingroup$

It's a brute force approach:

set = CharacterRange["A", "E"];
n = 4;
tuples = Tuples[set, n];

Select[tuples, Order[#[[1]], #[[2]]] == 1 && And @@ Negative@Differences@Ordering@Rest[#] &]

{"A", "C", "B", "A"}, {"A", "D", "B", "A"}, {"A", "D", "C", "A"}, {"A", "D", "C", "B"}, {"A", "E", "B", "A"}, {"A", "E", "C", "A"}, {"A", "E", "C", "B"}, {"A", "E", "D", "A"}, {"A", "E", "D", "B"}, {"A", "E", "D", "C"}, {"B", "C", "B", "A"}, {"B", "D", "B", "A"}, {"B", "D", "C", "A"}, {"B", "D", "C", "B"}, {"B", "E", "B", "A"}, {"B", "E", "C", "A"}, {"B", "E", "C", "B"}, {"B", "E", "D", "A"}, {"B", "E", "D", "B"}, {"B", "E", "D", "C"}, {"C", "D", "B", "A"}, {"C", "D", "C", "A"}, {"C", "D", "C", "B"}, {"C", "E", "B", "A"}, {"C", "E", "C", "A"}, {"C", "E", "C", "B"}, {"C", "E", "D", "A"}, {"C", "E", "D", "B"}, {"C", "E", "D", "C"}, {"D", "E", "B", "A"}, {"D", "E", "C", "A"}, {"D", "E", "C", "B"}, {"D", "E", "D", "A"}, {"D", "E", "D", "B"}, {"D", "E", "D", "C"}}

$\endgroup$
1
$\begingroup$

Use Rest in the condition:

rank = 4;
weight = 3;

X = Range@rank;
subst = Thread[X -> {a, b, c, d}];
bc = Tuples[X, weight]
Cases[bc, x_ /; x[[1]] > x[[2]] && LessEqual @@ Rest@x] /. subst
{{b, a, a}, {b, a, b}, {b, a, c}, {b, a, d}, {c, a, a}, {c, a, b},
 {c, a, c}, {c, a, d}, {c, b, b}, {c, b, c}, {c, b, d}, {d, a, a},
 {d, a, b}, {d, a, c}, {d, a, d}, {d, b, b}, {d, b, c}, {d, b, d},
 {d, c, c}, {d, c, d}}
$\endgroup$
1
$\begingroup$
Block[{k = 
   CharacterRange["A", "D"] /. 
    Thread[CharacterRange["A", "D"] -> 
      Range[Length[CharacterRange["A", "D"]]]], 
  ca}, {ca = Tuples[k, Length[k]]; 
  Cases[ca, {a_, b_, c_, d_} /; a > b && b < c < d] /. 
   Thread[CharacterRange["A", "D"] -> 
      Range[Length[CharacterRange["A", "D"]]] // Reverse]}]

{{{"B", "A", "B", "C"}, {"B", "A", "B", "D"}, {"B", "A", "C", "D"}, {"C", "A", "B", "C"}, {"C", "A", "B", "D"}, {"C", "A", "C", "D"}, {"C", "B", "C", "D"}, {"D", "A", "B", "C"}, {"D", "A", "B", "D"}, {"D", "A", "C", "D"}, {"D", "B", "C", "D"}}}

$\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.