Re: optimally picking one element from each list
- To: mathgroup at smc.vnet.net
- Subject: [mg48357] Re: optimally picking one element from each list
- From: DrBob <drbob at bigfoot.com>
- Date: Tue, 25 May 2004 07:17:33 -0400 (EDT)
- References: <006101c441a2$c69fdf10$6400a8c0@Main>
- Sender: owner-wri-mathgroup at wolfram.com
As usual, Carl's solution is brilliant!
Here's my reworked solution, using LinearProgramming. It's much more involved than necessary, as Carl has shown, but it may be useful to somebody teaching linear programming or shortest-path methods.
The Tableau option is only for small problems, of course. (Equations might be used for slightly bigger problems.) I suspect this uses most its time setting up the problem, and less than 5% solving it.
Clear[optimalSplit]
Options[optimalSplit] = {Equations -> False, Tableau -> False};
optimalSplit[test_List, opts___Rule] := Block[
{equations, tableau, elements, intersections, x, y,
z, nodes, arcs, n, a, h, rules, mm, m, bb, b, c},
{equations, tableau} = {Equations, Tableau} /. Join[{opts}, Options[
optimalSplit]];
elements = Flatten[MapIndexed[Thread[x[First@#2, #1]] &, test], 1];
intersections = z @@@ Flatten[MapIndexed[
Thread[{First@#2, #1}] &, Intersection @@@ Partition[test, 2, 1]], 1];
ColumnForm[nodes = Join[{"obj"}, x /@ Range@Length@test,
elements, {dummy}]];
ColumnForm[arcs = Join[elements, y @@@ elements,
intersections, {"RHS"}]];
{n, a} = Length /@ {nodes, arcs};
h[i_, j_] := {nodes[[i]], arcs[[j]]};
rules = {{i_, i_} -> 1, {x[i_], x[i_, j_]} -> -1, {i_x,
i_} -> 1, {x[i__], z[i__]} -> -1, {x[
i_, j_], z[ii_, j_]} /; ii == i -
1 -> 1, {x[1], "RHS"} -> -1, {"obj", y[i_, _]} /; i < Length[
test] -> 1, {x[i__], y[i__]} -> -1, {x[i_],
y[ii_, j_]} /; ii == i - 1 -> 1, {dummy, y[
Length@test, _]} -> 1, {dummy, "RHS"} -> 1, {_, _} -> 0};
mm = Array[h, {n, a}] /. rules;
m = mm[[Range[2, Length@nodes], Range[Length@arcs - 1]]];
b = Array[0 &, Length@nodes - 1];
b = mm[[Range[2, Length@mm], -1]];
b = Thread[{b, 0}];
c = mm[[1, Range[Length@arcs - 1]]];
If[equations, Print[Thread[
m.Drop[arcs, -1] == b[[All, 1]]] // ColumnForm]];
If[tableau, Print@TableForm[Transpose[mm], TableHeadings -> Reverse@ {
nodes, arcs}]];
soln = Transpose@{Most@arcs, LinearProgramming[c, m, b]};
{Length@Split@#, #} &[Sort[soln /. {{_, 0} ->
Sequence[], {y[__], 1} -> Sequence[], {x[i_, j_],
1} -> {i, j}, {z[i_, j_], 1} -> {i + 1, j}}][[All, -1]]]
]
test = Array[Union[Array[Random[Integer, 10] & , 4]] & , 3]
optimalSplit[test]
optimalSplit[test, Equations -> True]
optimalSplit[test, Tableau -> True]
Here's Carl's solution again:
pick[data_]:=Module[{common,tmp},common={};
tmp=Reverse[If[(
common=Intersection[common,#])\[Equal]{},common=#,common]&/@data];
common=.;
{Length@Split@#,#}&@Reverse[If[MemberQ[#,common],
common,common=First[#]]&/@tmp]
]
test=Array[Union@Array[Random[Integer,10]&,4]&,10]
Timing[pick@test]
Timing[optimalSplit@test]
Bobby
On Mon, 24 May 2004 11:21:15 -0400, Carl K. Woll <carlw at u.washington.edu> wrote:
> Daniel,
>
> Here is a solution, which I think is correct, and which ought to be
> considerably faster than the others that have been proposed. I couldn't get
> the other solutions to work, so I did not bother to compare timings.
>
> pick[data_]:=Module[{common,tmp},
> common={};
>
> tmp=Reverse[If[(common=Intersection[common,#])=={},common=#,common]&/@data];
> common=.;
> Reverse[If[MemberQ[#,common],common,common=First[#]]&/@tmp]
> ]
>
> Basically, you start at the beginning, and find the element which gives you
> the longest string of common elements. Once the string can no longer be
> extended, start a new string. It seems to me that this algorithm ought to
> give you a correct answer (there are many correct answers).
>
> Carl Woll
>
> "Daniel Reeves" <dreeves at umich.edu> wrote in message
> news:c8mugt$a3l$1 at smc.vnet.net...
>> Suppose you have a list of lists and you want to pick one element from
>> each and put them in a new list so that the number of elements that are
>> identical to their next neighbor is maximized.
>> (in other words, for the resulting list l, minimize Length[Split[l]].)
>> (in yet other words, we want the list with the fewest interruptions of
>> identical contiguous elements.)
>>
>> EG, pick[{ {1,2,3}, {2,3}, {1}, {1,3,4}, {4,1} }]
>> --> { 2, 2, 1, 1, 1 }
>>
>> Here's a preposterously brute force solution:
>>
>> pick[x_] := argMax[-Length[Split[#]]&, Distribute[x, List]]
>>
>> where argMax can be defined like so:
>>
>> (* argMax[f,domain] returns the element of domain for which f of
>> that element is maximal -- breaks ties in favor of first occurrence.
>> *)
>> SetAttributes[argMax, HoldFirst];
>> argMax[f_, dom_List] := Fold[If[f[#1] >= f[#2], #1, #2] &,
>> First[dom], Rest[dom]]
>>
>> Below is an attempt at a search-based approach, which is also way too
>> slow. So the gauntlet has been thrown down. Anyone want to give it a
>> shot?
>>
>>
>> (* Used by bestFirstSearch. *)
>> treeSearch[states_List, goal_, successors_, combiner_] :=
>> Which[states=={}, $Failed,
>> goal[First[states]], First[states],
>> True, treeSearch[
>> combiner[successors[First[states]], Rest[states]],
>> goal, successors, combiner]]
>>
>> (* Takes a start state, a function that tests whether a state is a goal
>> state, a function that generates a list of successors for a state, and
>> a function that gives the cost of a state. Finds a goal state that
>> minimizes cost.
>> *)
>> bestFirstSearch[start_, goal_, successors_, costFn_] :=
>> treeSearch[{start}, goal, successors,
>> Sort[Join[#1,#2], costFn[#1] < costFn[#2] &]&]
>>
>> (* A goal state is one for which we've picked one element of every list
>> in l.
>> *)
>> goal[l_][state_] := Length[state]==Length[l]
>>
>> (* If in state s we've picked one element from each list in l up to list
>> i, then the successors are all the possible ways to extend s to pick
>> elements thru list i+1.
>> *)
>> successors[l_][state_] := Append[state,#]& /@ l[[Length[state]+1]]
>>
>> (* Cost function g: higher cost for more neighbors different
>> (Length[Split[state]]) and then breaks ties in favor of longer
>> states to keep from unnecessarily expanding the search tree.
>> *)
>> g[l_][state_] :=
> Length[Split[state]]*(Length[l]+1)+Length[l]-Length[state]
>>
>> (* Pick one element from each of the lists in l so as to minimize the
>> cardinality of Split, ie, maximize the number of elements that are
>> the same as their neighbor.
>> *)
>> pick[l_] := bestFirstSearch[{}, goal[l], successors[l], g[l]]
>>
>>
>> --
>> http://ai.eecs.umich.edu/people/dreeves - - google://"Daniel Reeves"
>>
>> If you must choose between two evils,
>> pick the one you've never tried before.
>>
>
>
>
>
>
--
Using M2, Opera's revolutionary e-mail client: http://www.opera.com/m2/