Optimally picking one element from each list

Asked 2011-04-13T06:39:25.000

I came across an old problem that you Mathematica/StackOverflow folks will probably like and that seems valuable to have on StackOverflow for posterity.

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.

For example:

pick[{ {1,2,3}, {2,3}, {1}, {1,3,4}, {4,1} }]
 --> {    2,      2,    1,     1,      1   }

(Or {3,3,1,1,1} is equally good.)

Here's a preposterously brute force solution:

pick[x_] := argMax[-Length@Split[#]&, Tuples[x]]

where argMax is as described here:
posmax: like argmax but gives the position(s) of the element x for which f[x] is maximal

Can you come up with something better? The legendary Carl Woll nailed this for me and I'll reveal his solution in a week.

list wolfram-mathematica puzzle

Edit Report

2 Answers

Could use integer linear programming. Here is code for that.

bestPick[lists_] := Module[
  {picks, span, diffs, v, dv, vars, diffvars, fvars,
    c1, c2, c3, c4, constraints, obj, res},
  span = Max[lists] - Min[lists];
  vars = MapIndexed[v[Sequence @@ #2] &, lists, {2}];
  picks = Total[vars*lists, {2}];
  diffs = Differences[picks];
  diffvars = Array[dv, Length[diffs]];
  fvars = Flatten[{vars, diffvars}];
  c1 = Map[Total[#] == 1 &, vars];
  c2 = Map[0 <= # <= 1 &, fvars];
  c3 = Thread[span*diffvars >= diffs];
  c4 = Thread[span*diffvars >= -diffs];
  constraints = Join[c1, c2, c3, c4];
  obj = Total[diffvars];
  res = Minimize[{obj, constraints}, fvars, Integers];
  {res[[1]], Flatten[vars*lists /. res[[2]] /. 0 :> Sequence[]]}
 ]

Your example:

lists = {{1, 2, 3}, {2, 3}, {1}, {1, 3, 4}, {4, 1}}

bestPick[lists]

Out[88]= {1, {2, 2, 1, 1, 1}}

For larger problems Minimize might run into trouble since it uses exact methods for solving relaxed LPs. In which case you might need to switch to NMinimize, and change the domain argument to a constraint of the form Element[fvars,Integers].

Daniel Lichtblau

answered 2011-04-13T16:24:03.557

A week is up! Here is the fabled solution from Carl Woll. (I tried to get him to post it himself. Carl, if you come across this and want to take official credit, just paste it in as a separate answer and I'll delete this one!)

pick[data_] := Module[{common,tmp}, 
  common = {};
  tmp = Reverse[If[(common = Intersection[common,#])=={}, common = #, common]& /@
                data];
  common = .;
  Reverse[If[MemberQ[#, common], common, common = First[#]]& /@ tmp]]

Still quoting Carl:

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).

answered 2011-04-20T07:26:54.833

Optimally picking one element from each list

2 Answers

Your Answer