Increasing scattered subsequence
- To: mathgroup at smc.vnet.net
- Subject: [mg80084] Increasing scattered subsequence
- From: DrMajorBob <drmajorbob at bigfoot.com>
- Date: Sun, 12 Aug 2007 07:15:27 -0400 (EDT)
- References: <fa11b990e477.46baf2d3@bgu.ac.il> <D370EB89-ACFD-4FFF-B4E7-84A25FF267C5@mimuw.edu.pl> <C82B7D4D-6C0B-47E1-8603-DEE030A6E387@mimuw.edu.pl> <f69ab100e04a.46bc3a23@bgu.ac.il> <28688943.1186820838583.JavaMail.root@m35>
- Reply-to: drmajorbob at bigfoot.com
> On 10 Aug 2007, at 10:12, Ivan Egorov wrote:
>
(snip)
>> Write a function maxima[lis_List] which, given a list of numbers,
>> produces a list of those numbers greater than all those
>> that precede them. For example
>>
>> maxima[{ 9, 2, 10, 3, 14, 9}] returns { 9, 10, 14}.
Combinatorica includes a function, LongestIncreasingSubsequence, that
returns the LONGEST increasing scattered subsequence. And here's a faster
code of my own:
Clear[zeroPad, singleLongest]
zeroPad[{}] = {0};
zeroPad[x_List] := x
singleLongest[x_List] :=
Module[{t = Append[x, 1 + Max@x], len, pred, path, max},
path[i_Integer, o___Integer] /; pred[i] != {} :=
path[Last@pred@i, i, o];
len[i_] := len[i] = Module[
{mx, prior, pick, nxt = t[[i]]},
pick = Pick[Range[i - 1], Take[t, i - 1] - nxt, _?Negative];
prior = len /@ pick;
mx = Max@zeroPad@prior;
pred[nxt] = t[[Pick[pick, prior, mx]]];
1 + mx];
len /@ Range@Length@t;
Most[(path@Last@t) /. path -> List]
]
Needs["Combinatorica`"]
n = 35;
s = Ordering@RandomReal[{0, 1}, n^2 + 1];
Timing[mine = singleLongest@s]
Timing[theirs = LongestIncreasingSubsequence@s]
theirs == mine
{1.39, {51, 64, 89, 131, 143, 148, 189, 193, 195, 197, 241, 255, 318,
332, 372, 393, 408, 444, 448, 468, 478, 491, 493, 497, 535, 536,
563, 581, 599, 613, 618, 620, 639, 648, 688, 725, 747, 753, 762,
766, 767, 802, 842, 850, 876, 950, 960, 961, 998, 1045, 1052, 1076,
1084, 1087, 1095, 1101, 1104, 1149, 1168, 1194}}
{12.375, {51, 64, 89, 131, 143, 148, 189, 193, 195, 197, 241, 255,
318, 332, 372, 393, 408, 444, 448, 468, 478, 491, 493, 497, 535,
536, 563, 581, 599, 613, 618, 620, 639, 648, 688, 725, 747, 753,
762, 766, 767, 802, 842, 850, 876, 950, 960, 961, 998, 1045, 1052,
1076, 1084, 1087, 1095, 1101, 1104, 1149, 1168, 1194}}
True
I call it "singleLongest" because the following code returns ALL the
optimal subsequences.
Clear[zeroPad, longest]
zeroPad[{}] = {0};
zeroPad[x_List] := x
longest[x_List] :=
Module[{t = Append[x, 1 + Max@x], len, pred, path, max},
path[i_Integer, o___Integer] /; pred[i] != {} :=
Flatten[path[#, i, o] & /@ pred[i]];
len[i_] := len[i] = Module[
{mx, prior, pick, nxt = t[[i]]},
pick = Pick[Range[i - 1], Take[t, i - 1] - nxt, _?Negative];
prior = len /@ pick;
mx = Max@zeroPad@prior;
pred[nxt] = t[[Pick[pick, prior, mx]]];
1 + mx];
len /@ Range@Length@t;
(path@Last@t) /. path[any__] :> Most@List[any]
]
n = 25;
s = Ordering@RandomReal[{0, 1}, n^2 + 1];
Timing[mine = longest@s;]
Timing[theirs = LongestIncreasingSubsequence@s]
MemberQ[mine, theirs]
Length@theirs
Length /@ mine // Union
Length@mine
{0.812, Null}
{3.625, {23, 27, 29, 39, 46, 54, 74, 82, 99, 137, 149, 173, 202, 205,
234, 258, 282, 284, 290, 291, 295, 322, 337, 344, 345, 347, 350,
351, 411, 421, 435, 445, 453, 461, 480, 520, 540, 568, 569, 592,
597, 598, 612, 615}}
True
44
{44}
4536
"longest" is fast when a reasonable number of optima exist (4536 in that
problem), but it can be slow in extreme cases:
n = 25;
s = Ordering@RandomReal[{0, 1}, n^2 + 1];
Timing[mine = longest@s;]
Timing[theirs = LongestIncreasingSubsequence@s]
MemberQ[mine, theirs]
Length@theirs
Length /@ mine // Union
Length@mine
{59.156, Null}
{3.61, {5, 36, 53, 61, 78, 117, 140, 157, 161, 197, 200, 209, 215,
229, 232, 234, 235, 246, 254, 271, 293, 328, 370, 372, 377, 378,
380, 385, 391, 398, 406, 416, 435, 451, 460, 474, 512, 514, 528,
558, 559, 572, 573, 578, 596, 619}}
True
46
{46}
359250
In case one NEEDS all 359250 solutions, it's only 16 times slower than the
built-in that returns just ONE.
Bobby
On Sat, 11 Aug 2007 01:22:04 -0500, Andrzej Kozlowski <akoz at mimuw.edu.pl>
wrote:
> First, please send such question to the MathGroup,
>
> mathgroup at smc.vnet.net
>
> not me personally. (I really have desire, tiem or ability to replace
> the enitre MathGroup.)
> So I have decided to post this question to the MathGroup in case
> someone else finds it interesting.
>
> Also, there is something about this question and the earlier you sent
> me that make sme suspicious. What do you say "you need to use
> recursion and pattern matching, Select and Join"? This sounds to me
> like some sort of test problem so I have decided to answer it but
> without using any of these functions (although it may not be the
> simplest way to do this). So here is my answer:
>
> ls = {9, 2, 10, 3, 14, 9};
>
> Reverse[Last[Last[Reap[NestWhile[With[{a = First[Ordering[#, -1]]},
> Sow[#[[a]]]; Take[#, a - 1]] &,ls,Length[#] > 0 &]]]]]
>
> {9, 10, 14}
>
>
> On 10 Aug 2007, at 10:12, Ivan Egorov wrote:
>
>> I have one more question.
>>
>>
>>
>> Write a function maxima[lis_List] which, given a list of numbers,
>> produces a list of those
>>
>> numbers greater than all those that precede them. For example
>>
>> maxima[{ 9, 2, 10, 3, 14, 9}] returns { 9, 10, 14}. You need to use
>> recursion, pattern matching,
>>
>> Select and Join.
>>
>>
>> =E2=80=8E
>
>
>
-- =
DrMajorBob at bigfoot.com