# Delete an element list recursively

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.

• I don't think that there is a built-in method for this specific task. But this one is reasonably simple, isn't it? FixedPoint[Delete[#, Position[Differences[#], _?Positive]] &, #] &? May 24, 2018 at 17:47
• Well, this seems faster than loop or nest. May 24, 2018 at 17:58
• @JakePan - what would you like the output for a list like {10, 9, 11, 12, 8, 7, 2, 3, 5, 4, 3, 2, 1} to be? May 24, 2018 at 18:02
• @JasonB. Should be {12, 8, 7, 5, 4, 3, 2, 1} May 24, 2018 at 18:13

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 *)

• ReplaceRepeated[{x___, PatternSequence[a_, b_] /; (a < b) , y___} :> {x, b, y}]@list as well.
– chuy
May 24, 2018 at 19:10

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}

• Although you're probably right and the OP might actually really want something related to the LIS, that is not quite what is described in the original question. For example, take {10, 9, 8, 7, 6, 7, 8, 7, 6, 7} Then your solution yields {10,9,8,7,6} whereas the original procedure gives {10,9,8,8,7,7} . Note that this is not solved simply changing Greater -> GreaterEqual, which would then yield {10,9,8,7,7,7,7} Jun 8, 2018 at 14:46
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).

• Crazy man.......
– yode
Jun 2, 2018 at 4:21
• i tried with a 30000 element long list. Carl's method was the first to complete the task (up to 1 order of magnitude faster than accidental's FixedPoint[Pick[]]method) Jun 3, 2018 at 15:45
• @Alucard, it seems that it depends on how much variation there is in the input list. With SeedRandom[1]; lst1=RandomSample[Range[30000]]; First/@{RepeatedTiming[fixedPointPick[lst1];], RepeatedTiming[descendingSequence[lst1];]} I get {0.0015, 0.038}, The results are similar with lst2 = RandomInteger[100000,30000]. With lst3 = RandomInteger[100,30000]; the timings are reversed: {0.0014, 0.00015}.
– kglr
Jun 5, 2018 at 11:30
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}

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

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