Message Boards Message Boards

0
|
7372 Views
|
4 Replies
|
4 Total Likes
View groups...
Share
Share this post:

Subsets of maximized length from a sorted list of integers

Posted 11 years ago
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};
POSTED BY: Todor Latev
4 Replies
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}}
POSTED BY: Udo Krause
Niama zashto! :-) Just an oversight, it is certainly better to localize the For iterators to avoid modifying any existing i or x.
POSTED BY: Ilian Gachevski
Posted 11 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
POSTED BY: Todor Latev
 
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.
POSTED BY: Ilian Gachevski
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract