List 从每个列表中最佳地选取一个元素

我遇到了一个你们Mathematica/StackOverflow的人可能会喜欢的老问题，这似乎对StackOverflow的后代很有价值

假设您有一个列表，并且希望从每个列表中选择一个元素，并将它们放入一个新列表中，以便最大化与其下一个邻居相同的元素数量。 换句话说，对于结果列表l，最小化Length@Split[l] 。 换句话说，我们希望列表中相同连续元素的中断最少

例如：

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

（或{3,3,1,1,1}同样好。）

这里有一个荒谬的暴力解决方案：

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

其中argMax如下所述：

你能想出更好的办法吗？

---

传奇人物卡尔·沃尔（Carl Woll）帮我解决了这个问题，我将在一周内公布他的解决方案。

我的解决方案是基于“贪婪是好的”这一观察结果。如果我可以在中断一条链和开始一条新的、可能很长的链之间做出选择，那么选择一条新链继续下去对我没有任何好处。新链变长的数量与旧链变短的数量相同

因此，该算法基本上是从第一个子列表开始，为其每个成员查找具有相同成员的附加子列表的数量，并选择具有最相邻双胞胎的子列表成员。然后，此过程在第一个链末尾的子列表继续，以此类推

因此，将其结合到递归算法中，我们最终得到：

pickPath[lst_] :=
 Module[{lengthChoices, bestElement},
  lengthChoices = 
   LengthWhile[lst, Function[{lstMember}, MemberQ[lstMember, #]]] & /@First[lst];
  bestElement = Ordering[lengthChoices][[-1]];
  If[ Length[lst] == lengthChoices[[bestElement]],
   ConstantArray[lst[[1, bestElement]], lengthChoices[[bestElement]]],
   {
    ConstantArray[lst[[1, bestElement]], lengthChoices[[bestElement]]],
    pickPath[lst[[lengthChoices[[bestElement]] + 1 ;; -1]]]
    }
   ]
  ]

---

测试

In[12]:= lst = 
 Table[RandomSample[Range[10], RandomInteger[{1, 7}]], {8}]

Out[12]= {{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2, 8, 5, 
  9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 7}, {6, 9, 
  4, 5}}

In[13]:= pickPath[lst] // Flatten // AbsoluteTiming

Out[13]= {0.0020001, {10, 10, 10, 10, 1, 9, 9, 9}}

argMax[f_, dom_List] := 
Module[{g}, g[e___] := g[e] = f[e];(*memoize*) dom[[Ordering[g /@ dom, -1]]]]
pick[x_] := argMax[-Length@Split[#] &, Tuples[x]]

In[14]:= pick[lst] // AbsoluteTiming

Out[14]= {0.7340420, {{10, 10, 10, 10, 1, 9, 9, 9}}}

---

Dreeves的暴力方法

In[12]:= lst = 
 Table[RandomSample[Range[10], RandomInteger[{1, 7}]], {8}]

Out[12]= {{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2, 8, 5, 
  9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 7}, {6, 9, 
  4, 5}}

In[13]:= pickPath[lst] // Flatten // AbsoluteTiming

Out[13]= {0.0020001, {10, 10, 10, 10, 1, 9, 9, 9}}

argMax[f_, dom_List] := 
Module[{g}, g[e___] := g[e] = f[e];(*memoize*) dom[[Ordering[g /@ dom, -1]]]]
pick[x_] := argMax[-Length@Split[#] &, Tuples[x]]

In[14]:= pick[lst] // AbsoluteTiming

Out[14]= {0.7340420, {{10, 10, 10, 10, 1, 9, 9, 9}}}

---

我第一次使用的测试列表稍微长一点。暴力手段使我的电脑几乎陷于停顿，占用了它所有的内存。很糟糕。我必须在10分钟后重新启动。重新启动花费了我另外四分之一的时间，因为PC变得非常无响应。

这是我对它的看法，它的功能与Sjoerd几乎相同，只是代码更少

LongestRuns[list_List] := 
 Block[{gr, f = Intersection}, 
  ReplaceRepeated[
    list, {a___gr, Longest[e__List] /; f[e] =!= {}, b___} :> {a, 
      gr[e], b}] /. 
   gr[e__] :> ConstantArray[First[f[e]], Length[{e}]]]

一些画廊：

In[497]:= LongestRuns[{{1, 2, 3}, {2, 3}, {1}, {1, 3, 4}, {4, 1}}]

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

In[498]:= LongestRuns[{{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 
   2, 8, 5, 9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 
   7}, {6, 9, 4, 5}}]

Out[498]= {{3, 3, 3, 3}, {1}, {9, 9, 9}}

In[499]:= pickPath[{{3, 10, 6}, {8, 2, 10, 5, 9, 3, 6}, {3, 7, 10, 2, 
   8, 5, 9}, {6, 9, 1, 8, 3, 10}, {1}, {2, 9, 4}, {9, 5, 2, 6, 8, 
   7}, {6, 9, 4, 5}}]

Out[499]= {{10, 10, 10, 10}, {{1}, {9, 9, 9}}}

In[500]:= LongestRuns[{{2, 8}, {4, 2}, {3}, {9, 4, 6, 8, 2}, {5}, {8, 
   10, 6, 2, 3}, {9, 4, 6, 3, 10, 1}, {9}}]

Out[500]= {{2, 2}, {3}, {2}, {5}, {3, 3}, {9}}

In[501]:= LongestRuns[{{4, 6, 18, 15}, {1, 20, 16, 7, 14, 2, 9}, {12, 
   3, 15}, {17, 6, 13, 10, 3, 19}, {1, 15, 2, 19}, {5, 17, 3, 6, 
   14}, {5, 17, 9}, {15, 9, 19, 13, 8, 20}, {18, 13, 5}, {11, 5, 1, 
   12, 2}, {10, 4, 7}, {1, 2, 14, 9, 12, 3}, {9, 5, 19, 8}, {14, 1, 3,
    4, 9}, {11, 13, 5, 1}, {16, 3, 7, 12, 14, 9}, {7, 4, 17, 18, 
   6}, {17, 19, 9}, {7, 15, 3, 12}, {19, 12, 5, 14, 8}, {1, 10, 12, 
   8}, {18, 16, 14, 19}, {2, 7, 10}, {19, 2, 5, 3}, {16, 17, 3}, {16, 
   2, 6, 20, 1, 3}, {12, 18, 11, 19, 17}, {12, 16, 9, 20, 4}, {19, 20,
    10, 12, 9, 11}, {10, 12, 6, 19, 17, 5}}]

Out[501]= {{4}, {1}, {3, 3}, {1}, {5, 5}, {13, 13}, {1}, {4}, {9, 9, 
  9}, {1}, {7, 7}, {9}, {12, 12, 12}, {14}, {2, 2}, {3, 3}, {12, 12, 
  12, 12}}

编辑鉴于Sjoerd的Dreeves的蛮力方法由于无法一次生成所有元组而在大样本上失败，下面是另一种蛮力方法：

bfBestPick[e_List] := Block[{splits, gr, f = Intersection},
  splits[{}] = {{}};
  splits[list_List] := 
   ReplaceList[
    list, {a___gr, el__List /; f[el] =!= {}, 
      b___} :> (Join[{a, gr[el]}, #] & /@ splits[{b}])]; 
  Module[{sp = 
     Cases[splits[
        e] //. {seq__gr, 
         re__List} :> (Join[{seq}, #] & /@ {re}), {__gr}, Infinity]}, 
   sp[[First@Ordering[Length /@ sp, 1]]] /. 
    gr[args__] :> ConstantArray[First[f[args]], Length[{args}]]]]

这个蛮力最佳选择可能会产生不同的分裂，但根据最初的问题，长度才是关键

test = {{4, 6, 18, 15}, {1, 20, 16, 7, 14, 2, 9}, {12, 3, 15}, {17, 6,
     13, 10, 3, 19}, {1, 15, 2, 19}, {5, 17, 3, 6, 14}, {5, 17, 
    9}, {15, 9, 19, 13, 8, 20}, {18, 13, 5}, {11, 5, 1, 12, 2}, {10, 
    4, 7}, {1, 2, 14, 9, 12, 3}, {9, 5, 19, 8}, {14, 1, 3, 4, 9}, {11,
     13, 5, 1}, {16, 3, 7, 12, 14, 9}, {7, 4, 17, 18, 6}, {17, 19, 
    9}, {7, 15, 3, 12}, {19, 12, 5, 14, 8}, {1, 10, 12, 8}, {18, 16, 
    14, 19}, {2, 7, 10}, {19, 2, 5, 3}, {16, 17, 3}, {16, 2, 6, 20, 1,
     3}, {12, 18, 11, 19, 17}, {12, 16, 9, 20, 4}, {19, 20, 10, 12, 9,
     11}, {10, 12, 6, 19, 17, 5}};

在这个例子中，pick失败

In[637]:= Length[bfBestPick[test]] // Timing

Out[637]= {58.407, 17}

In[638]:= Length[LongestRuns[test]] // Timing

Out[638]= {0., 17}

In[639]:= 
Length[Cases[pickPath[test], {__Integer}, Infinity]] // Timing

Out[639]= {0., 17}

---

我发布这篇文章是为了防止有人想搜索反例，比如pickPath或LongestRuns代码确实生成了中断次数最少的序列

可以使用整数线性规划。下面是代码

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[]]}
 ]

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

对于更大的问题，Minimize可能会遇到麻烦，因为它使用精确的方法来解决问题。在这种情况下，您可能需要切换到NMinimize，并将域参数更改为form元素[fvars，Integers]的约束

---

丹尼尔·利奇特布拉

我会把这个扔进拳击场。我不确定它是否总是给出一个最优的解决方案，但它似乎与给出的其他一些答案的逻辑相同，而且速度很快

f@{} := (Sow[m]; m = {i, 1})
f@x_ := m = {x, m[[2]] + 1}

findruns[lst_] :=
  Reap[m = {{}, 0}; f[m[[1]] ⋂ i] ~Do~ {i, lst}; Sow@m][[2, 1, 2 ;;]]

findruns

提供运行长度编码输出，包括并行答案。如果需要严格规定的输出，请使用：

Flatten[First[#]~ConstantArray~#2 & @@@ #] &

---

这是一个使用折叠的变体。在某些设置的形状上速度更快，但在其他形状上速度稍慢

f2[{}, m_, i_] := (Sow[m]; {i, 1})
f2[x_, m_, _] := {x, m[[2]] + 1}

findruns2[lst_] :=
  Reap[Sow@Fold[f2[#[[1]] ⋂ #2, ##] &, {{}, 0}, lst]][[2, 1, 2 ;;]]

下面是我的“一行”和Wizard先生的改进：

 pickPath[lst_List] :=
 Module[{M = Fold[{#2, #} &, {{}}, Reverse@lst]},
   Reap[While[M != {{}},
      Do[Sow@#[[-2,1]], {Length@# - 1}] &@
       NestWhileList[# ⋂ First[M = Last@M] &, M[[1]], # != {} &]
   ]][[2, 1]]
 ]

它基本上在连续的列表上重复使用交集，直到结果为空，然后一次又一次地使用交集。在一个巨大的酷刑测试案例中

M = Table[RandomSample[Range[1000], RandomInteger[{1, 200}]], {1000}];

在我的2GHz Core 2 Duo上，我的计时一直在0.032左右

---

下面是我的第一次尝试，我将留给你们仔细阅读

对于给定的元素列表

M

，我们计算不同的元素和列表的数量，按规范顺序列出不同的元素，并构造一个矩阵

K[i，j]

，详细说明元素

i

在列表

j

中的存在：

elements = Length@(Union @@ M);
lists = Length@M;
eList = Union @@ M;
positions = Flatten@Table[{i, Sequence @@ First@Position[eList, M[[i,j]]} -> 1,
                          {i, lists},
                          {j, Length@M[[i]]}];
K = Transpose@Normal@SparseArray@positions;

现在的问题相当于从左到右遍历这个矩阵，只需按1，并尽可能少地更改行

为了实现这一点，我对行进行排序，在开始时取一个最连续的1，跟踪我选择的元素，

从
K
中删除多个列，然后重复：

R = {};
While[Length@K[[1]] > 0,
   len = LengthWhile[K[[row = Last@Ordering@K]], # == 1 &];
   Do[AppendTo[R, eList[[row]]], {len}];
   K = Drop[#, len] & /@ K;
]

这有一个
绝对计时
大约是进近时间的三倍。
这是一个尝试

runsByN：对于每个数字，显示它是否出现在每个子列表中
runsByN
被
list
转置，插入零表示缺失的数字。它显示了出现1、2、3和4的子列表


myPick：选择构成最佳路径的数字
myPick
递归地构建最长运行的列表。它不是寻找所有的最优解，而是寻找最小长度的第一个解

myPick[{}, c_] := Flatten[c]
myPick[l_, c_: {}] := 
   Module[{r = Length /@ (l /. {x___, 0, ___} :> {x}), m}, m = Max[r];
   myPick[Cases[(Drop[#, m]) & /@ l, Except[{}]], 
   Append[c, Table[Position[r, m, 1, 1][[1, 1]], {m}]]]]
choices = myPick[runsByN]
(* Out= {7, 7, 7, 7, 7, 7, 7, 7, 1, 1, 1, 10, 10, 10, 3, 3, 3, 3, 3, 1, 1, 6, 6, 1, 1, 1, 6, 10, 6, 7} *)

感谢Wizard先生建议使用替换规则作为
TakeWhile
的有效替代方案


结束语：可视化解决方案路径
下表显示了
列表中的数据。
每个标绘点对应一个数字及其所在的子列表

一周时间到了！这是卡尔·沃尔传说中的解决方案。（我试着让他自己把它贴出来。卡尔，如果你遇到这个问题并想获得官方认可，就把它作为一个单独的答案粘贴进去，我会删除这个！）

仍然引用卡尔的话：

基本上，你从一开始就开始，找到给你答案的元素
公共元素的最长字符串。一旦字符串不再可用
扩展，开始一个新字符串。在我看来，这个算法应该
给你一个正确的答案（有很多正确的答案）

不是一个答案，而是一个比较
runsPlot[choices1_, runsN_] := 
  Module[{runs = {First[#], Length[#]} & /@ Split[choices1], myArrow,
          m = Max[runsN]},
  myArrow[runs1_] :=
     Module[{data1 = Reverse@First[runs1], data2 = Reverse[runs1[[2]]],
      deltaX},
      deltaX := data2[[1]] - 1;
      myA[{}, _, out_] := out;           
      myA[inL_, deltaX_, outL_] :=
        Module[{data3 = outL[[-1, 1, 2]]},
        myA[Drop[inL, 1], inL[[1, 2]] - 1, 
          Append[outL, Arrow[{{First[data3] + deltaX, 
           data3[[2]]}, {First[data3] + deltaX + 1, inL[[1, 1]]}}]]]];
        myA[Drop[runs1, 2], deltaX, {Thickness[.005], 
            Arrow[{data1, {First[data1] + 1, data2[[2]]}}]}]];

  ListPlot[runsN,
     Epilog -> myArrow[runs],
     PlotStyle -> PointSize[Large],
     Frame -> True,
     PlotRange -> {{1, Length[choices1]}, {1, m}},
     FrameTicks -> {All, Range[m]},
     PlotRangePadding -> .5,
     FrameLabel -> {"Sublist", "Number", "Sublist", "Number"},
     GridLines :>    {FoldList[Plus, 0, Length /@ Split[choices1]], None}
   ]];

runsPlot[choices, runsByN]

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

Table[RandomSample[Range[10], RandomInteger[{1, 7}]], {rl}]

lst = Table[RandomSample[Range[ch], RandomInteger[{1, ch}]], {50}];