Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Given a set $S$ and a partial order $\prec$ over $S$, I'm looking for a way to "efficiently" generate a list of linear extensions of $\prec$. Suppose the partial order is given by a List of pairs $\{x,y\}$ such that $x,y\in S$. For example, if $S = \{a,b,c\}$, then $\{\{a,c\},\{b,c\}\}$ defines a partial order where $a \prec c$ and $b \prec c$.

Essentially, given a list $S$ and a list of pairs $P$, I want to generate a list of permutations which respect the orders of the pairs in $P$.

linearExtensions[{a, b, c, d, e}, {{a, b}, {c, b}, {c, d}, {e, d}}]
(* {{a, c, b, e, d}, {a, c, e, b, d}, {a, c, e, d, b}, {a, e, c, b, d},
    {a, e, c, d, b}, {c, a, b, e, d}, {c, a, e, b, d}, {c, a, e, d, b},
    {c, e, a, b, d}, {c, e, a, d, b}, {c, e, d, a, b}, {e, a, c, b, d},
    {e, a, c, d, b}, {e, c, a, b, d}, {e, c, a, d, b}, {e, c, d, a, b}} *)

Since $\{a,b\}$ is in $P$, the permutation $\{b, c, a, d, e\}$ is not a linear extension because $b$ comes before $a$.

I've written two different functions which do the job, both using pattern matching, but I've been using Mathematica for less than a week and am still getting into the functional mindset. I'm interested to see how seasoned Mathematica users would tackle this problem.

My first approach was to use NestWhile (edit: this is ugly! I did not know about the Fold[] function when I wrote this):

linearExtensions[set_, po_] := 
    Module[{patterns},
        patterns = {___, #[[1]], ___, #[[2]], ___}& /@ po;
        First@NestWhile[{Cases[#[[1]], First[#[[2]]]], Rest[#[[2]]]}&,
            {Permutations[set], patterns}, Length[#[[2]]] > 0&]
    ]

My second approach, which turned out to be significantly slower, was to expand a set of rules from the partial order and use Select on the list of permutations.

linearExtensions[set_, po_] :=
    Module[{poQ},
        poQ[rule_] := And @@ (MatchQ[rule, {___, #[[1]], ___, #[[2]], ___}]& /@ po);
        Select[Permutations[set], poQ[#]&]
    ]

Note that on a list of length $n$ there can be $\Omega(n!)$ linear extensions, so by "efficient," I don't mean polynomial-time.

share|improve this question
    
What's $\Omega$? –  alancalvitti Aug 4 '12 at 20:14
1  
@alancalvitti The counter part to Big O. $\Omega$ is an asymptotic lower bound –  rm -rf Aug 4 '12 at 20:43
    
@R.M, same as small $o$? –  alancalvitti Aug 6 '12 at 2:28
    
@alancalvitti $\Omega$ is an asymptotic lower bound. Think of $O$ as $\le$, $o$ as $<$, and $\Omega$ as $\ge$. (The analogy falls apart for some pairs of functions which are neither $O$ nor $\Omega$ of each other.) –  Zach Langley Aug 6 '12 at 2:37
add comment

3 Answers 3

up vote 4 down vote accepted

Could use integer linear programming. In Mathematica this can be done with Reduce[]. One way (probably not the best) to set this up is shown below. It uses an array of 0-1 variables, where a 1 in position (j,k) will indicate that the kth element of the input variables goes in position j of a particular ordering.

Caveat: I may have mixed up rows and columns.

consistentOrders[elems_, pairorders_] := Module[
  {n = Length[elems], vars, x, fvars, c1, c2, c3, c4, constraints, 
   ineqs, solns},
  ineqs[{a1_, a2_}, n_, v_] := 
   Table[Total[Take[v[[All, a1]], j]] >= 
     Total[Take[v[[All, a2]], j]], {j, 1, n - 1}];
  vars = Array[x, {n, n}];
  fvars = Flatten[vars];
  c1 = Map[0 <= # <= 1 &, fvars];
  c2 = Thread[Total[vars] == 1];
  c3 = Thread[Total[Transpose@vars] == 1];
  c4 = Flatten[
    Map[ineqs[#, n, vars] &, pairorders /. Thread[elems -> Range[n]]]];
  constraints = Join[c1, c2, c3, c4];
  solns = Reduce[constraints, fvars, Integers];
  solns = 
   solns /. {(_ == 0) :> Sequence[], aa_ == 1 :> aa, And -> List, 
     Or -> List};
  Sort[solns /. x[i_, j_] :> elems[[j]]]
  ]

--- edit ---

The first three constraint sets are fairly standard for this type of 0-1 programming. The fourth constraint subset arises as follows. The idea is that if the jth list element must precede the kth, then the 1 in column j must occur in an earlier row than the one in column k. So for every 1<=m<=n-1 (n=dimension) the sum of the first m entries in col j >= corresponding sum in col k.

--- end edit --- Example:

consistentOrders[{a, b, c, d, 
  e}, {{a, b}, {c, b}, {c, d}, {e, d}}]

(* Out[83]= {{a, c, b, e, d}, {a, c, e, b, d}, {a, c, e, d, b}, {a, e, c,
   b, d}, {a, e, c, d, b}, {c, a, b, e, d}, {c, a, e, b, d}, {c, a, e,
   d, b}, {c, e, a, b, d}, {c, e, a, d, b}, {c, e, d, a, b}, {e, a, c,
   b, d}, {e, a, c, d, b}, {e, c, a, b, d}, {e, c, a, d, b}, {e, c, d,
   a, b}} *)

Bigger example:

vars = {a, b, c, d, e, f, g, h, i, j, k, l};
porderlist = {{a, c}, {b, c}, {f, g}, {g, e}, {d, a}, {h, i}, {i, 
    d}, {g, h}, {g, i}, {h, j}, {h, k}, {k, j}, {k, c}};

Timing[ss = consistentOrders[vars, porderlist];]

(* Out[81]= {60.03, Null}

In[82]:= Length[ss]

Out[82]= 12840 *)
share|improve this answer
    
Can you explain the fourth constraint? –  Zach Langley Aug 6 '12 at 4:52
    
Not easily... See edited response. –  Daniel Lichtblau Aug 6 '12 at 14:27
    
Ohhh, I see. Nice! I didn't think to use integer programming for this. This is certainly the most efficient solution so far. –  Zach Langley Aug 6 '12 at 14:34
    
Although it's not as concise, I'm accepting this answer because its performance trumps the others'. –  Zach Langley Aug 10 '12 at 23:49
add comment

A more concise version of the first approach, using Fold[] instead of NestWhile[]:

linearExtensions[set_, po_] :=
    Fold[Cases, Permutations[set], {___, #1, ___, #2, ___} & @@@ po]
share|improve this answer
1  
Or, linearExtensions[set_, po_] := Fold[Cases[#1, Riffle[#2, ___, {1, -1, 2}]] &, Permutations[set], po] –  J. M. Aug 4 '12 at 17:40
add comment

My first modest attempt:

linearExtensions[set_List, po_?MatrixQ] :=
    Select[Permutations[set], Complement[po, Subsets[#, {Last[Dimensions[po]]}]] === {} &]

My second modest attempt:

linearExtensions[set_List, po_?MatrixQ] :=
  Select[Permutations[set], And @@ Map[Function[p, LongestCommonSequence[#, p] === p], po] &]
share|improve this answer
    
Nice! I didn't realize Subsets preserved order. Is there no nicer way to determine if a list is a subset of another than what you're doing here? –  Zach Langley Aug 4 '12 at 15:13
    
If there is one, I do not know it. –  J. M. Aug 4 '12 at 15:57
    
Interestingly, the pattern matching seems to be much faster than this. Try, for example, with linearExtensions[{a, b, c, d, e, f, g, h, i}, {{a, c}, {b, c}, {f, g}, {g, e}, {d, a}, {h, i}, {i, d}, {g, h}}]. –  Zach Langley Aug 5 '12 at 14:46
    
@Zach, yes; it seems your approach is a good bit faster... anyway, I gave another possibility. –  J. M. Aug 5 '12 at 14:47
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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