Problem: Given a sequence of values and a predicate that expresses a total ordering on some set including all of those values, determine the longest subsequence of the sequence that increases monotonically with respect to that ordering. We get the best solution if we can insist that the original sequence is presented as a vector (for random access) and the monotonically increasing subsequence as a list (since it will be built up one element at a time, sequentially, and its length is initially unknown). Since it's not difficult to convert from one format to the other during pre- or post-processing, let's help ourselves to this assumption.
In the algorithm presented here, we'll traverse the vector from left to right, determining for each position in the vector the longest monotonically increasing subsequence of the vector that ends at that position. The solution will then be the longest such subsequence ending at any position in the vector.
We need to store these intermediate results, and the handiest way to hold them is another vector, here called result. So that we don't have to compute the length of these intermediate-result subsequences over and over again, we'll store each one as a pair in which the cdr is the subsequence itself, in reverse order (so that the most recently appended value is accessible) and the car is its length.
The main loop of the program constructs these intermediate results, keeping
track of the longest one. Each result is constructed by calling an
internally defined procedure longest-available
, which searches
through the previously constructed intermediate results, looking for
subsequences to which the value in the current position of the vector can
be appended. It selects and returns the longest of these, which is
returned as the procedure's value. (If the value in the current position
cannot be appended to any of the available subsequences, a null sequence is
returned instead.)
(define longest-monotone-subsequence (lambda (vec . opt) (let* ((precedes? (if (null? opt) < (car opt))) (len (vector-length vec)) (result (make-vector len)) (longest-available (lambda (position candidate) (let loop ((trial 0) (len 0) (subseq '())) (if (= trial position) (cons len subseq) (let* ((trial-subseq (vector-ref result trial)) (trial-len (car trial-subseq)) (last-of-trial-subseq (cadr trial-subseq))) (if (and (< len trial-len) (precedes? last-of-trial-subseq candidate)) (loop (+ trial 1) trial-len (cdr trial-subseq)) (loop (+ trial 1) len subseq)))))))) (let loop ((index 0) (length-of-longest 0) (longest '())) (if (= index len) (reverse longest) (let* ((current (vector-ref vec index)) (base (longest-available index current))) (let ((new-length (+ (car base) 1)) (new-subseq (cons current (cdr base)))) (vector-set! result index (cons new-length new-subseq)) (if (< length-of-longest new-length) (loop (+ index 1) new-length new-subseq) (loop (+ index 1) length-of-longest longest)))))))))
This document is available on the World Wide Web as
http://www.math.grin.edu/~stone/events/scheme-workshop/monotone.html