Subsets of maximized length from a sorted list of integers

Questions
,
1

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 that

b2-b1=x
b3-b2=x
b4-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 possible

How does one go about finding the x and the subset b ?

Thanks in advance

PS> 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};
2

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.

3

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

Niama zashto! :slight_smile: Just an oversight, it is certainly better to localize the For iterators to avoid modifying any existing i or x.

5

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