Delete an element list recursively

Question

I have a list, say {10,9,8,7,2,3,5,4,3,2,1}

What I want to achieve is to delete the elements that are not in decreasing order recursively. Namely, the output should be {10,9,8,7,5,4,3,2,1}, which deletes {2,3} in the list.

I am seeking some elegant and efficient way to do so. Naively, I have thought about these methods:

1. Using a loop and starting from the first element, compare the current element with the next element. Remove the current if current < next, and move the pointer to the previous element. Do it recursively until the next is smaller than the current. Clearly, this is a procedural programming which is not preferable in Mathematica.

2. Using Nest[]. First do Difference[list] and remove all the positive elements. Update list and do it recursively until the Difference[list] are all negative.

3. Using Nest[] and find the minimal peaks in the list, delete the peak step by step.

All these methods use loops or Nest and hence are not very efficient. I am wondering if there is a built-in function that can do this efficiently.

Answer 1

list = {10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1};
list //. {a___, b_, c_, d___} /; c > b -> {a, c, d}
(* {12, 8, 7, 5, 4, 3, 2, 1} *)
FixedPoint[Pick[#, Append[UnitStep[Differences[#]], 0], 0] &, list]
(* same output, slightly faster *)
Reverse@DeleteDuplicates[Reverse@list, Greater]
(* same output, slightly faster *)

Also, (a comment by Henrik Schumacher),

FixedPoint[Delete[#, Position[Differences[#], _?Positive]] &, #] &@list
(* same output *)

and (a comment by chuy)

list //. {x___, PatternSequence[a_, b_] /; (a < b), y___} :> {x, b, y}
(* same output *)

Answer 2

It looks like you want the longest descending sequence starting with the max value. I think the following will do what you want:

descendingSequence[list_] := LongestOrderedSequence[
    list[[First @ Ordering[list,-1] ;; ]],
    Greater
]

Examples:

descendingSequence[{10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1}]
descendingSequence[{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1}]

{10, 9, 8, 7, 5, 4, 3, 2, 1}

{12, 8, 7, 5, 4, 3, 2, 1}

Answer 3

f1 = FixedPoint[SequenceReplace[#, {a_, b_} /; Less[a, b] :> b] &, #] &;

And a faster variation of AccidentalFourierTransform's second method:

f2 = Reverse @ DeleteDuplicates[FoldList[Max, Reverse @ #]]&;

f1[{10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1}]

{10, 9, 8, 7, 5, 4, 3, 2, 1}

f1[{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1}]

{12, 8, 7, 5, 4, 3, 2, 1}

f1[{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 15, 2, 1, 20}]

{20}

f1 @ # == f2 @ # & /@ 
{{10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1}, 
{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1} ,
{10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 15, 2, 1,20} }

{True, True, True}

Note: Carl's method both produces longer lists and is faster than any of the methods posted so far (except AccidentalFourierTransform's first method).

Answer 4

la = {10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1};

Using SequenceSplit (new in 11.3)

Flatten @ SequenceSplit[la, {a_, b_} /; a < b]

{10, 9, 8, 7, 5, 4, 3, 2, 1}

lb = {10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1};

lc = Flatten @ SequenceSplit[lb, {a_, b_} /; a < b]

{10, 12, 8, 7, 5, 4, 3, 2, 1}

To start with the largest element we use PositionLargest (new in 13.2)

lc[[First @ PositionLargest @ lc ;;]]

{12, 8, 7, 5, 4, 3, 2, 1}

With SequenceCases we must append -Infinity to catch the last element

First /@ SequenceCases[Append[-Infinity] @ la, {a_, b_} /; a > b, Overlaps -> True]

{10, 9, 8, 7, 5, 4, 3, 2, 1}

Answer 5

FixedPoint[Delete[#, Position[ListConvolve[{-1, 1}, #], _?(# <= 0 &)]] &, list]

Answer 6

alist = {10, 9, 8, 7, 2, 3, 5, 4, 3, 2, 1};
res = {10, 9, 8, 7, 5, 4, 3, 2, 1};

(Split[alist, Less] // Map[Last] ) == res

(* True *)

The above shows one step only (enough in this case) but it has to be wrapped in FixedPoint until the output becomes a strictly descending list.

---

Visualization:

To cook up an example showing the recursive operation, we start with a descending list and introduce a few shuffles.

SeedRandom[1];
blist = Range[20, 1, -1] // 
   SubsetMap[RotateLeft, #, RandomInteger[{1, 20}, 2]] & //
  SubsetMap[RotateLeft, #, RandomInteger[{1, 20}, 2]] &;

t = Most@FixedPointList[Last /@ Split[#, Less] &, blist];

{{13, 19, 18, 17, 16, 20, 14, 15, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1}, {19, 18, 17, 20, 15, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1}, {19, 18, 20, 15, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1}, {19, 20, 15, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1}, {20, 15, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1}}

---