Generating Linear Extensions of a Partial Order
A more concise version of the first approach, using Fold[]
instead of NestWhile[]
:
linearExtensions[set_, po_] :=
Fold[Cases, Permutations[set], {___, #1, ___, #2, ___} & @@@ po]
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 *)
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] &]