9
$\begingroup$

I'm interested in finding the longest monotonically increasing subsequence of a sequence containing the final two elements. This question addresses my question without the italicized requirement. For example, given {3,4,6,7,5,8}, the function should return {3,4,5,8}, not {3,4,6,7,8}. (In fact, I only need the length of that longest subsequence, but a function returning the subsequence is fine too.)

We may assume that lst[[Length@lst-1]] < Last@lst and that the elements of lst are distinct.

EDIT: Note that this is the same problem as determining the longest increasing subsequence including the final element - given such an algorithm, apply it to Rest@lst to get the longest increasing subsequence containing the last two elements.

Improve this question
$\endgroup$
2
  • $\begingroup$ What if the last two elements are, e.g., {8,5}? No such subsequence will be monotonically increasing. $\endgroup$ Commented Sep 12, 2016 at 17:12
  • 1
    $\begingroup$ @corey979 Note that I assumed the last two elements were in increasing order. $\endgroup$ Commented Sep 12, 2016 at 17:14

5 Answers 5

Reset to default
10
$\begingroup$

Using Leonid Shifrin's solution from the Q&A you mentioned:

longestSequence[{seq___, a_, b_}] := With[{list = Select[{seq}, # < a &]}, Join[LongestCommonSequence[list, Sort@list], {a, b}] ]
Improve this answer
$\endgroup$
1
  • $\begingroup$ So neat...so clear :) $\endgroup$ Commented Sep 13, 2016 at 22:41
4
$\begingroup$

This is sufficiently different from my other answer. I have, therefore,chosento post it separately.

func[ls_] := Module[{tag = Thread[{Range[Length@ls], ls}], gr, vl, jn, mx}, gr = RelationGraph[#2[[1]] > #1[[1]] && #2[[2]] > #1[[2]] &, tag]; vl = VertexList[gr]; jn = Join @@ (Catch[ Do[With[{w = FindPath[gr, #, tag[[-2]], {n}]}, If[Length@w != 0, Throw[w], If[n == 1, Throw[{}]]]], {n, Length@ls, 1, -1}]] & /@ vl); mx = Max[Length /@ jn]; {mx + 1, #[[All, 2]]~Join~{ls[[-1]]}, HighlightGraph[gr, ##~Join~{tag[[-1]]}, VertexLabels -> Table[j -> Framed[j[[2]], Background -> White], {j, vl}], Prolog -> {Red, Thick, Line /@ Partition[ GraphEmbedding[ gr][[##~Join~{tag[[-1]]} /. Thread[vl -> Range[Length[vl]]]]], 2, 1]}, ImageSize -> {400, 400}]} & /@ Pick[jn, Length[#] == mx & /@ jn] ]

There is a lot of 'window dressing' that can be removed. The output is the length of longest strictly increasing subsequence terminating in the last two entries of given sequence., some examples and the highlighted graph.

Tesing:

lst = {3, 4, 6, 7, 5, 8}; Column[Column[#, Alignment -> Center] & /@ func[lst], Alignment -> Center, Frame -> True] ri = RandomInteger[{1, 10}, 15]~Join~{5, 8} Row[Column[#, Frame -> True, Alignment -> Center] & /@ func[ri]]

enter image description here

enter image description here

Improve this answer
$\endgroup$
3
$\begingroup$

Just for fun, since obvious solutions already posted. Returns the length that OP requested, quite quick...

longSeq= Compile[{{lst, _Integer, 1}}, Module[{ba = Pick[lst, UnitStep[lst[[-1]] - lst], 1], ta, c1=1, m1 = 0}, ta = ConstantArray[Max@ba + 1, Length@ba]; Do[ While[ta[[c1]] < ca, c1++]; ta[[c1]] = ca; m1 = Max[m1, c1]; c1=1; , {ca, ba}]; m1] ];

More to the point, this is very fast:

longSeq2=Length[LongestOrderedSequence[Pick[#,UnitStep[#[[-1]]-#],1]]]&;
Improve this answer
$\endgroup$
1
$\begingroup$

For small lists a brute force way:

lst = {3, 4, 6, 7, 5, 8}; fun[u_] := Module[ {su = Rest@Subsets[u], end = u[[-2 ;; -1]], c, p, lg}, If[Sort@end == end, c = Cases[su, {__, ##} & @@ end]; p = Pick[c, # == Sort@# & /@ c]; lg = Length[p[[-1]]]; Return[{"length" -> lg, "examples" -> Pick[p, Length[#] == lg & /@ p]}] , "not non-decreasing"]; ] g[u_, v_] := v /. fun[u]

e.g.

g[lst, "length"] g[lst, "examples"]

Improve this answer
$\endgroup$
0
$\begingroup$

Direct credit to ubpdqn's answer for reminding me about Subsets. A somewhat differet manipulation of them though.

This finds the longest strictly monotonic subsequences:

longest[lst_] := Module[{min, lst1, rest, lst2}, min = Min@Take[lst, -2]; lst1 = Drop[lst, -2]; rest = Subsets@lst1; lst2 = DeleteDuplicates /@ DeleteDuplicates@ DeleteCases[Select[#1, # < min &] & /@ rest, {}]; Join[#, Take[lst, -2]] & /@ MaximalBy[Intersection[lst2, Sort /@ lst2], Length] ] longest@{4, 5, 3, 2, 4, 4, 6, 2, 7, 5, 5, 8}

{{2, 4, 5, 8}, {3, 4, 5, 8}}

longest@RandomInteger[{1, 9}, 20];//AbsoluteTiming

{1.16609, Null}

longest@RandomInteger[{1, 9}, 25];//AbsoluteTiming

{48.2002, Null}

longest@RandomInteger[{1, 9}, 27];//AbsoluteTiming

{213.568, Null}

It crashes for a list of length 28 though.

Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.