# Find longest monotonically increasing subsequence containing final two elements

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.

• What if the last two elements are, e.g., {8,5}? No such subsequence will be monotonically increasing. – corey979 Sep 12 '16 at 17:12
• @corey979 Note that I assumed the last two elements were in increasing order. – rogerl Sep 12 '16 at 17:14

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

• So neat...so clear :) – ubpdqn Sep 13 '16 at 22:41

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[] && #2[] > #1[] &, 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[], Background -> White], {j, vl}],
Prolog -> {Red, Thick,
Line /@ Partition[
GraphEmbedding[
gr][[##~Join~{tag[[-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]]  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]]]&;


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"] 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.