# Subsets of maximized length from a sorted list of integers

GROUPS:
 A relatively simple mathematical problem/not for me though/Given is a sorted list of integers: a = {a1,a2,a3,...an}I need to find a subset b={b1,b2,b3...bm}such thatb2-b1=xb3-b2=xb4-b3=x...Where x is an integer and x>0.Among all possible subsets b, I'm interested in the ones with the maximum length, ie m should be as big as possibleHow does one go about finding the x and the subset b ?Thanks in advancePS> Here's a sample list to work with:a={459, 468, 486, 495, 549, 567, 576, 594, 639, 648, 657, 675, 693, \729, 738, 783, 792, 819, 837, 846, 864, 873, 891, 918, 927, 936, 945, \954, 963, 972, 981};
4 years ago
4 Replies
 Ilian Gachevski 4 Votes A naive brute force approach would be to iterate through all possible values for b1 and x, keeping track of the maximal b found so far, for example  In[2]:= Module[{b = {}, i, k, m = 1, s, x},  For[i = 1, i < Length[a], i++,   For[x = 1, x < (Last[a] - a[[i]])/m, x++,    s = {}; k = 0;    While[MemberQ[a, a[[i]] + k x], AppendTo[s, a[[i]] + k x]; k++];    If[Length[s] >= m, b = s; m = Length[s]]    ]   ];  b]Out[2]= {918, 927, 936, 945, 954, 963, 972, 981} For a much more efficient algorithm with O(n^2) complexity, see this article.
4 years ago
 Merci otnovo Iliane!Interesting - turns out this was not as simple as I thought..The routine seems to work just fine and does the job. In this case the answer I was after was indeed 8, but I wasn't sure if other valid answers existed.Finally just a quick remark on your code - is there a reason why you didn't localize the i var as well?I'm assuming normally it should have been included in the Module definition
4 years ago
 Niama zashto! :-) Just an oversight, it is certainly better to localize the For iterators to avoid modifying any existing i or x.
4 years ago
 The x taking 1, 2, 3, 4, ... is a time eater, Ilian's In[2] is latev1[l_] := Module[{b = {}, i, k, m = 1, s, x},    For[i = 1, i < Length[l], i++,     For[x = 1, x < (Last[l] - l[[i]])/m, x++,      s = {l[[i]]};      k = 1;      While[MemberQ[l, l[[i]] + k x], AppendTo[s, l[[i]] + k x]; k++];      If[Length[s] >= m, b = s; m = Length[s]]      ]     ];   b   ] /; VectorQ[l, IntegerQ] && OrderedQ[l]take the x at real differences only instead latevAP[l_] := Module[{b = {}, i, j, k, m = 1, s, x},    For[i = 1, i < Length[l], i++,     For[j = i + 1, j <= Length[l], j++,      x = l[[j]] - l[[i]];      If[x < 1 || x >= (Last[l] - l[[i]])/m, Break[]];      s = {l[[i]], l[[j]]};      k = 2;      While[MemberQ[l, l[[i]] + k x], AppendTo[s, l[[i]] + k x]; k++];      If[Length[s] >= m, b = s; m = Length[s]]     ]    ];   b   ] /; VectorQ[l, IntegerQ] && OrderedQ[l]and try some data In[5]:= a2 = FoldList[Plus, 3, 23 RandomInteger[5, 500]];  In[7]:= Length[a2] Out[7]= 501  In[8]:= OrderedQ[a2] Out[8]= True  In[9]:= Timing[latev1[a2]]Out[9]= {39.733455, {6604, 8812, 11020, 13228, 15436, 17644, 19852, 22060, 24268, 26476}}In[20]:= Timing[latevAP[a2]]Out[20]= {0.811205, {6604, 8812, 11020, 13228, 15436, 17644, 19852, 22060, 24268, 26476}}