sequences.lisp

(in-package :serapeum)

;;; Some of this API is based on
;;; https://common-lisp.net/project/sequence-iterators/.

(deftype function-name ()
  '(and symbol (not (member t nil))))

(deftype key-designator ()
  '(or null function-name function))

(deftype test-designator ()
  '(or null function-name function))

(deftype signed-array-index ()
  "A (possibly negated) array index."
  '#.(let ((limit (1- array-dimension-limit)))
       `(integer (,(- limit)) (,limit))))

(deftype signed-array-length ()
  "A (possibly negated) array length."
  '#.(let ((limit (1- array-dimension-limit)))
       `(integer ,(- limit) ,limit)))

(defsubst sequencep (x)
  "Is X a sequence?"
  (typep x 'sequence))

(-> canonicalize-key (key-designator) function)
(defun canonicalize-key (k)
  (etypecase-of key-designator k
    (null #'identity)
    (function-name (fdefinition k))
    (function k)))

(-> canonicalize-test (test-designator &optional test-designator)
    function)
(defun canonicalize-test (test &optional test-not)
  (flet ((canonicalize (test)
           (etypecase-of test-designator test
             (null #'eql)
             (function-name (fdefinition test))
             (function test))))
    (cond ((and test test-not)
           (error "Cannot supply both ~s and ~s to a sequence function" 'test 'test-not))
          (test (canonicalize test))
          (test-not (canonicalize test-not))
          (t #'eql))))

(-> key-test (key-designator test-designator &optional test-designator)
    function)
(defun key-test (key test &optional test-not)
  "Return a function of two arguments which uses KEY to extract the
part of the arguments to compare, and compares them using TEST."
  (declare (optimize (safety 1) (debug 0)))
  (let ((key (canonicalize-key key))
        (test (canonicalize-test test test-not)))
    (if (eql key #'identity) test
        (fbind key
          (with-test-fn (test)
            (lambda (x y)
              (test (key x) (key y))))))))

(defun make-sequence-like (seq len &rest args &key initial-element
                                                   (initial-contents nil ic?))
  "Helper function: make a sequence of length LEN having the same type as SEQ."
  (seq-dispatch seq
    (if ic?
        (map 'list #'identity initial-contents)
        (make-list len :initial-element initial-element))
    (apply #'make-array len :element-type (array-element-type seq) args)
    #+(or sbcl abcl) (apply #'sequence:make-sequence-like seq len args)))

(define-do-macro do-vector ((var vec &optional return) &body body)
  "Iterate over the items of a vector in a manner similar to `dolist'."
  ;; TODO See if any other implementations expose something similar.
  #+ccl `(ccl:dovector (,var ,vec ,@(unsplice return))
           ,@body)
  #+sbcl `(sb-int:dovector (,var ,vec ,@(unsplice return))
            ,@body)
  #-(or ccl sbcl) `(map nil (lambda (,var) ,@body) ,vec))

(define-do-macro %do-each ((var seq &optional return) &body body)
  "Only for Lisps that do not support extensible sequences."
  (once-only (seq)
    `(seq-dispatch ,seq
       (dolist (,var ,seq)
         ,@body)
       (do-vector (,var ,seq)
         ,@body))))

(define-do-macro do-each/map ((var seq &optional return) &body body)
  "The simple, out-of-line version."
  (with-thunk (body var)
    `(map nil ,body ,seq)))

(defmacro do-each ((var seq &optional return) &body body &environment env)
  "Iterate over the elements of SEQ, a sequence.
If SEQ is a list, this is equivalent to `dolist'."
  (when (policy> env 'space 'speed)
    (return-from do-each
      `(do-each/map (,var ,seq ,@(unsplice return))
         ,@body)))
  ;; We hoist the body and use sb-ext:muffle-conditions to prevent
  ;; SBCL from spamming us with code deletion notes. (It may also be
  ;; desirable in itself to avoid needless code duplication in Lisps
  ;; without type inference.)
  (with-thunk (body var)
    (let ((iter-spec `(,var ,seq ,@(unsplice return))))
      `(locally (declare #+sbcl (sb-ext:muffle-conditions sb-ext:code-deletion-note))
         #+(or sbcl abcl)
         (sequence:dosequence ,iter-spec
           (,body ,var))
         #-(or sbcl abcl)
         (%do-each ,iter-spec
           (,body ,var))))))

(declaim (inline map-subseq))
(defun map-subseq (fn seq &optional start end from-end)
  "Helper function to map SEQ between START and END."
  (declare (type (or null array-index) start end)
           (optimize (debug 0) (safety 1)
                     (compilation-speed 0)))
  ;; (when (and start end)
  ;;   (assert (<= start end)))
  (let ((start (or start 0))
        (fn (ensure-function fn)))
    (fbind (fn)
      (seq-dispatch seq
        (if (null end)
            (if from-end
                (list-map-from-end/bordeaux fn seq :start start)
                (dolist (item (nthcdr start seq))
                  (fn item)))
            (if from-end
                (list-map-from-end/bordeaux fn seq :start start :end end)
                (loop for item in (nthcdr start seq)
                      for i below (- end start)
                      do (fn item))))
        (with-subtype-dispatch vector
            (simple-bit-vector
             bit-vector
             (simple-array character (*))
             simple-base-string)
            seq
          (let ((end (or end (length seq))))
            (if from-end
                (loop for i downfrom (1- end) to start
                      do (fn (vref seq i)))
                (loop for i from start below end
                      do (fn (vref seq i))))))
        (let ((end (or end (length seq))))
          (if from-end
              (loop for i downfrom (1- end) to start
                    do (fn (elt seq i)))
              (loop for i from start below end
                    do (fn (elt seq i)))))))))
(declaim (notinline map-subseq))

(define-do-macro do-subseq ((var seq &optional return
                                 &key start
                                 end
                                 from-end)
                            &body body)
  `(map-subseq
    (lambda (,var)
      ,@body)
    ,seq
    ,start ,end
    ,from-end))

;;; Define a protocol for accumulators so we can write functions like
;;; `assort', `partition', &c. generically.

(defmacro with-list-bucket ((seq) &body body)
  "Wrap BODY with inlined bucket accessors for lists."
  (declare (ignore seq))
  `(flet ((make-bucket (seq &optional (init nil initp))
            (declare (ignore seq))
            (if initp
                (queue init)
                (queue)))
          (bucket-push (seq item bucket)
            (declare (ignore seq)
                     (queue bucket))
            (enq item bucket))
          (bucket-seq (seq bucket)
            (declare (ignore seq)
                     (queue bucket))
            (qlist bucket)))
     (declare (ignorable #'make-bucket #'bucket-push #'bucket-seq))
     (declare (inline make-bucket bucket-push bucket-seq))
     ,@body))

(defmacro with-string-bucket ((seq) &body body)
  "Wrap BODY with inlined bucket accessors for strings."
  (declare (ignore seq))
  `(flet ((make-bucket (seq &optional (init nil initp))
            (let ((stream
                    (make-string-output-stream
                     :element-type (array-element-type seq))))
              (and initp (write-char init stream))
              stream))
          (bucket-push (seq item bucket)
            (declare (ignore seq))
            (write-char item bucket))
          (bucket-seq (seq bucket)
            (declare (ignore seq))
            (get-output-stream-string bucket)))
     (declare (ignorable #'make-bucket #'bucket-push #'bucket-seq))
     (declare (inline make-bucket bucket-push bucket-seq))
     ,@body))

(defmacro with-vector-bucket ((seq) &body body)
  "Wrap BODY with inlined bucket accessors for vectors (including strings)."
  `(if (stringp ,seq)
       (with-string-bucket (,seq)
         ,@body)
       (flet ((make-bucket (seq &optional (init nil initp))
                (with-boolean (initp)
                  (make-array (eif initp 1 0)
                              :element-type (array-element-type seq)
                              :adjustable t
                              :fill-pointer (eif initp 1 0)
                              :initial-contents (and initp (list init)))))
              (bucket-push (seq item bucket)
                (declare (ignore seq))
                (vector-push-extend item bucket))
              (bucket-seq (seq bucket)
                (declare (ignore seq))
                bucket))
         (declare (ignorable #'make-bucket #'bucket-push #'bucket-seq))
         (declare (inline make-bucket bucket-push bucket-seq))
         ,@body)))

(defmacro with-sequence-bucket ((seq) &body body)
  "Wrap BODY with inlined bucket accessors for generic sequences.

This might not seem worthwhile, and it's not for `bucket-seq', but for
`bucket-push' (and even `make-bucket') it is, since accumulating for
generic sequences just uses queues."
  (declare (ignore seq))
  `(flet ((make-bucket (seq &optional (init nil initp))
            (declare (ignore seq))
            (if initp
                (queue init)
                (queue)))
          (bucket-push (seq item bucket)
            (declare (ignore seq)
                     (queue bucket))
            (enq item bucket))
          (bucket-seq (seq bucket)
            (declare (queue bucket))
            (let ((len (qlen bucket)))
              (make-sequence-like seq len :initial-contents (qlist bucket)))))
     (declare (ignorable #'make-bucket #'bucket-push #'bucket-seq))
     (declare (inline make-bucket bucket-push bucket-seq))
     ,@body))

(defmacro with-specialized-buckets ((seq) &body body)
  "Ensure BODY is run with the appropriate specialized, inlined
versions of the bucket accessors.

This is only likely to be worthwhile around a loop; if you're calling
a bucket accessor once or twice the code bloat isn't worth it."
  (multiple-value-bind (body decls) (parse-body body)
    `(locally
         (declare #+sbcl (sb-ext:muffle-conditions sb-ext:code-deletion-note))
       ,@decls
       (with-type-declarations-trusted ()
         (seq-dispatch ,seq
           (with-list-bucket (,seq)
             ,@body)
           (with-vector-bucket (,seq)
             ,@body)
           (with-sequence-bucket (,seq)
             ,@body))))))

;;; Fallback versions for non-specialized code.

(defun make-bucket (seq &optional (init nil initp))
  "Return a \"bucket\" suitable for collecting elements from SEQ.

If SEQ is restricted as to the type of elements it can hold (for
example, if SEQ is an array with an element type) the same restriction
will apply to the bucket."
  (with-specialized-buckets (seq)
    (if initp
        (make-bucket seq init)
        (make-bucket seq))))

(defun bucket-push (seq item bucket)
  "Insert ITEM at the end of BUCKET according to SEQ."
  (with-specialized-buckets (seq)
    (bucket-push seq item bucket)))

(defun bucket-seq (seq bucket)
  "Return a sequence \"like\" SEQ using the elements of BUCKET.

Note that it is not safe to call the function more than once on the
same bucket."
  (with-specialized-buckets (seq)
    (bucket-seq seq bucket)))

;;; Not currently used, but probably should be.
(defun bucket-append (seq items bucket)
  "Append ITEMS to the end of BUCKET according to SEQ.

The items will appear, together and in the same order, in the
sequence taken from the bucket by BUCKET-SEQ."
  (cond ((and (listp seq)
              (listp items))
         (qappend bucket items))
        ((stringp seq)
         (write-string items bucket))
        (t
         (map nil (lambda (item)
                    (bucket-push seq item bucket))
              items))))

(-> nsubseq
    (sequence array-index &optional (or null array-length))
    sequence)
(defun nsubseq (seq start &optional end)
  "Return a subsequence that may share structure with SEQ.

Note that `nsubseq' gets its aposematic leading `n' not because it is
itself destructive, but because, unlike `subseq', destructive
operations on the subsequence returned may mutate the original.

`nsubseq' also works with `setf', with the same behavior as
`replace'."
  (seq-dispatch seq
    (cond (end (subseq seq start end))
          ((= start 0) seq)
          (t (nthcdr start seq)))
    (let* ((len (length seq))
           (end (or end len)))
      (if (and (= start 0) (= end len))
          seq
          ;; TODO Would it be better to undisplace the vector first?
          (make-array (- end start)
                      :element-type (array-element-type seq)
                      :displaced-to seq
                      :displaced-index-offset start)))
    (let ((end (length seq)))
      (if (and (= start 0)
               (or (no end)
                   (= end (length seq))))
          seq
          (subseq seq start end)))))

(defun (setf nsubseq) (value seq start &optional end)
  "Destructively set SEQ between START and END to VALUE.
Uses `replace' internally."
  (replace seq value :start1 start :end1 end)
  value)

(defun filter/counted (pred seq &rest args
                       &key count from-end (start 0) end
                            (key #'identity))
  "Helper for FILTER."
  (cond
    ;; Simple cases.
    ((= count 0) (make-sequence-like seq 0))
    ((> count (length seq)) (apply #'filter pred seq :count nil args))
    (t (fbind (pred)
         (let ((ret (make-bucket seq)))
           (with-item-key-function (key)
             (with-specialized-buckets (seq)
               (do-subseq (item seq nil :start start :end end :from-end from-end)
                 (when (pred (key item))
                   (bucket-push seq item ret)
                   (when (zerop (decf count))
                     (return))))))
           (let ((seq2 (bucket-seq seq ret)))
             (if from-end (nreverse seq2) seq2)))))))

(defun filter (pred seq &rest args &key count &allow-other-keys)
  "Almost, but not quite, an alias for `remove-if-not'.

The difference is the handling of COUNT: for `filter', COUNT is the
number of items to *keep*, not remove.

     (remove-if-not #'oddp '(1 2 3 4 5) :count 2)
     => '(1 3 5)

     (filter #'oddp '(1 2 3 4 5) :count 2)
     => '(1 3)"
  (if count
      (apply #'filter/counted pred seq args)
      (apply #'remove-if-not pred seq args)))

(define-compiler-macro filter (&whole decline
                                      pred seq
                                      &rest args
                                      &key count
                                      &allow-other-keys)
  "In the absence of COUNT, expand directly to `remove-if-not'."
  (if (null count)
      `(remove-if-not ,pred ,seq ,@args)
      decline))

(declaim (inline filter/swapped-arguments))
(defun filter/swapped-arguments (seq pred &rest args &key &allow-other-keys)
  (apply #'filter pred seq args))

(define-modify-macro filterf (pred &rest args)
  filter/swapped-arguments
  "Modify-macro for FILTER.
The place designed by the first argument is set to the result of
calling FILTER with PRED, the place, and ARGS.")

(defun keep (item seq &rest args &key (test #'eql) from-end key count
             &allow-other-keys)
  "Almost, but not quite, an alias for `remove` with `:test-not` instead of `:test`.

The difference is the handling of COUNT. For keep, COUNT is the number of items to keep, not remove.

     (remove 'x '(x y x y x y) :count 2)
     => '(y y x y)

     (keep 'x '(x y x y x y) :count 2)
     => '(x x)

`keep' becomes useful with the KEY argument:

     (keep 'x ((x 1) (y 2) (x 3)) :key #'car)
     => '((x 1) (x 3))"
  (declare (ignore from-end key))
  (let ((args (remove-from-plist args :test)))
    (if (null count)
        (apply #'remove item seq :test-not test args)
        (fbind ((test (partial test item)))
          (declare (dynamic-extent #'test))
          (apply #'filter #'test seq :count count args)))))

(define-compiler-macro keep (&whole decline
                                    item seq
                                    &rest args
                                    &key (test '#'eql) count
                                    &allow-other-keys)
  "In the absence of COUNT, expand directly to `remove'."
  (if (null count)
      `(remove ,item ,seq :test-not ,test ,@(remove-from-plist args :test))
      decline))

(-> single (sequence) boolean)
(defsubst single (seq)
  "Is SEQ a sequence of one element?"
  (seq-dispatch seq
    (and seq (endp (cdr seq)))
    (= (length seq) 1)))

(deftype single ()
  '(and sequence (satisfies single)))

(defun only-elt (seq)
  "Return the only element of SEQ.
If SEQ is empty, or contains more than one element, signal an error."
  (flet ((fail ()
           (error 'type-error
                  :expected-type 'single
                  :datum seq)))
    (declare (dynamic-extent #'fail))
    (seq-dispatch seq
      (if (and seq
               (endp (rest seq)))
          (first seq)
          (fail))
      (if (= (length seq) 1)
          (elt seq 0)
          (fail)))))

;;; TODO Export once you're sure of the name.
(defun rotation (seq n)
  "Like `rotate', but non-destructive."
  (rotate (copy-seq seq) n))

(defun partition (pred seq &key (start 0) end (key #'identity))
  "Partition elements of SEQ into those for which PRED returns true
and false.

Return two values, one with each sequence.

Exactly equivalent to:
     (values (remove-if-not predicate seq) (remove-if predicate seq))
except it visits each element only once.

Note that `partition` is not just `assort` with an up-or-down
predicate. `assort` returns its groupings in the order they occur in
the sequence; `partition` always returns the “true” elements first.

    (assort '(1 2 3) :key #'evenp) => ((1 3) (2))
    (partition #'evenp '(1 2 3)) => (2), (1 3)"
  (fbind ((test (compose pred (canonicalize-key key))))
    (let ((pass (make-bucket seq))
          (fail (make-bucket seq)))
      (with-specialized-buckets (seq)
        (do-subseq (item seq nil :start start :end end)
          (if (test item)
              (bucket-push seq item pass)
              (bucket-push seq item fail))))
      (values (bucket-seq seq pass) (bucket-seq seq fail)))))

(defun partitions (preds seq &key (start 0) end (key #'identity))
  "Generalized version of PARTITION.

PREDS is a list of predicates. For each predicate, `partitions'
returns a filtered copy of SEQ. As a second value, it returns an extra
sequence of the items that do not match any predicate.

Items are assigned to the first predicate they match."
  (with-item-key-function (key)
    (with-specialized-buckets (seq)
      (let ((buckets (loop for nil in preds collect (make-bucket seq)))
            (extra (make-bucket seq)))
        (do-subseq (item seq nil :start start :end end)
          (loop for pred in preds
                for bucket in buckets
                for fn = (ensure-function pred)
                if (funcall fn (key item))
                  return (bucket-push seq item bucket)
                finally (bucket-push seq item extra)))
        (values (mapcar-into (lambda (bucket)
                               (bucket-seq seq bucket))
                             buckets)
                (bucket-seq seq extra))))))

(defconstructor agroup
  "Auxiliary data structure for `assort'. A pair of an exemplar (to
compare against) and a bucket of matching items. Note that while the
agroup is immutable, the bucket itself is mutable."
  (exemplar t)
  (bucket t))

(defun assort (seq &key (key #'identity) (test #'eql) (start 0) end)
  "Return SEQ assorted by KEY.

     (assort (iota 10)
             :key (lambda (n) (mod n 3)))
     => '((0 3 6 9) (1 4 7) (2 5 8))

Groups are ordered as encountered. This property means you could, in
principle, use `assort' to implement `remove-duplicates' by taking the
first element of each group:

     (mapcar #'first (assort list))
     ≡ (remove-duplicates list :from-end t)

However, if TEST is ambiguous (a partial order), and an element could
qualify as a member of more than one group, then it is not guaranteed
that it will end up in the leftmost group that it could be a member
of.

    (assort '(1 2 1 2 1 2) :test #'<=)
    => '((1 1) (2 2 1 2))"
  (fbind (test)
    (with-item-key-function (key)
      (let ((groups (queue))
            last-group)
        (with-specialized-buckets (seq)
          (do-subseq (item seq nil :start start :end end)
            (let ((kitem (key item)))
              (if-let ((group
                        (if (match last-group
                              ((agroup exemplar _)
                               (test kitem exemplar)))
                            last-group
                            (find-if
                             (lambda (exemplar)
                               (test kitem exemplar))
                             (qlist groups)
                             :key #'agroup-exemplar))))
                (progn
                  (setf last-group group)
                  (bucket-push seq item (agroup-bucket group)))
                (enq (agroup kitem (make-bucket seq item))
                     groups))))
          (mapcar-into (lambda (group)
                         (bucket-seq seq (agroup-bucket group)))
                       (qlist groups)))))))

(defun list-runs (list start end key test)
  (fbind ((test (key-test key test)))
    (declare (dynamic-extent #'test))
    ;; This is a little more complicated than you might expect,
    ;; because we need to keep hold of the first element of each list.
    (let ((runs
            (reduce
             (lambda (runs y)
               (if (null runs)
                   (list (list y))
                   (let ((x (caar runs)))
                     (if (test x y)
                         (cons (list* x y (cdar runs))
                               (cdr runs))
                         (list* (list y)
                                (cons (caar runs)
                                      (nreverse (cdar runs)))
                                (cdr runs))))))
             list
             :start start
             :end end
             :initial-value nil)))
      (nreverse (cons (cons (caar runs)
                            (nreverse (cdar runs)))
                      (cdr runs))))))

(defun runs (seq &key (start 0) end (key #'identity) (test #'eql))
  "Return a list of runs of similar elements in SEQ.
The arguments START, END, and KEY are as for `reduce'.

    (runs '(head tail head head tail))
    => '((head) (tail) (head head) (tail))

The function TEST is called with the first element of the run as its
first argument.

    (runs '(1 2 3 1 2 3) :test #'<)
    => ((1 2 3) (1 2 3))"
  (if (emptyp seq)
      (list seq)
      (seq-dispatch seq
        (list-runs seq start end key test)
        (fbind ((test (key-test key test)))
          (declare (dynamic-extent #'test))
          (collecting*
            (nlet runs ((start start))
              (let* ((elt (elt seq start))
                     (pos (position-if-not (partial #'test elt)
                                           seq
                                           :start (1+ start)
                                           :end end)))
                (if (null pos)
                    (collect (subseq seq start end))
                    (progn
                      (collect (subseq seq start pos))
                      (runs pos))))))))))

(defun batches (seq n &key (start 0) end even)
  "Return SEQ in batches of N elements.

    (batches (iota 11) 2)
    => ((0 1) (2 3) (4 5) (6 7) (8 9) (10))

If EVEN is non-nil, then SEQ must be evenly divisible into batches of
size N, with no leftovers."
  #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
  (check-type n (integer 0 *))
  (check-type start (integer 0 *))
  (flet ((uneven ()
           (error "A ~@[sub~*~]sequence of length ~a cannot be evenly divided into batches of size ~a."
                  end
                  (- (or end (length seq)) start)
                  n)))
    (declare (dynamic-extent #'uneven))
    (flet ((check-bounds-even (start end)
             (when even
               (unless (zerop (rem (- end start) n))
                 (uneven)))))
      (declare (inline check-bounds-even))
      (seq-dispatch seq
        (let ((seq (nthcdr start seq)))
          (if (null end)
              (with-boolean (even)
                (loop while seq
                      collect (loop for i below n
                                    for (elt . rest) on seq
                                    collect elt
                                    finally (setf seq rest)
                                            (when even
                                              (unless (= i n)
                                                (uneven))))))
              (progn
                (check-bounds-even start end)
                (with-boolean (even)
                  (loop while seq
                        for i from start below end by n
                        collect
                        (loop with m = (min n (- end i))
                              for i below m
                              for (elt . rest) on seq
                              collect elt
                              finally (setf seq rest)
                                      (when even
                                        (unless (= i m)
                                          (uneven)))))))))
        (let ((end (or end (length seq))))
          (check-bounds-even start end)
          (nlet batches ((i start)
                         (acc '()))
            (if (>= i end)
                (nreverse acc)
                (batches (+ i n)
                         (cons (subseq seq i (min (+ i n) end))
                               acc)))))))))

(defun frequencies (seq &rest hash-table-args &key (key #'identity)
                                                   &allow-other-keys)
  "Return a hash table with the count of each unique item in SEQ.
As a second value, return the length of SEQ.

From Clojure."
  (let ((total 0)
        ;; Using multiple-value-call lets us specify defaults while
        ;; still ensuring the caller can override them.
        (table (multiple-value-call #'make-hash-table
                 (values-list (remove-from-plist hash-table-args :key))
                 :size (values (floor (length seq) 2))
                 :test 'equal)))
    (declare (fixnum total))
    (with-item-key-function (key)
      (if (typep seq 'bit-vector)
          (with-subtype-dispatch bit-vector (simple-bit-vector) seq
            (setf (gethash (key 0) table) (count 0 seq)
                  (gethash (key 1) table) (count 1 seq)
                  total (length seq)))
          (do-each (elt seq)
            (incf total)
            (incf (gethash (key elt) table 0)))))
    (values table total)))

(defun scan (fn seq
              &rest args
              &key from-end
              (start 0)
              (end (length seq))
              (initial-value nil initial-value-supplied?)
              &allow-other-keys)
  "Return the partial reductions of SEQ.

Each element of the result sequence is the result of calling `reduce'
on the elements of the sequence up to that point (inclusively).

    (reduce #'+ '(1))       => 1
    (reduce #'+ '(1 2))     => 3
    (reduce #'+ '(1 2 3))   => 6
    (reduce #'+ '(1 2 3 4)) => 10
    (scan   #'+ '(1 2 3 4)) => '(1 3 6 10)

The result of calling `scan` on an empty sequence is always an empty
sequence, however.

    (reduce #'+ '()) => 0
    (scan   #'+ '()) => '()

This is sometimes called a \"prefix sum\", \"cumulative sum\", or
\"inclusive scan\".

From APL."
  (fbind (fn)
    (if (= start end)
        (if initial-value-supplied?
            ;; NB reduce does not apply the key to the initial value
            ;; if the sequence is empty.
            (list initial-value)
            (list))
        (collecting
          (collect
              (apply #'reduce
                     (if from-end
                         (lambda (x y)
                           (collect y)
                           (fn x y))
                         (lambda (x y)
                           (collect x)
                           (fn x y)))
                     seq
                     args))))))

(defsubst nub (seq &rest args &key start end key (test #'equal))
  "Remove duplicates from SEQ, starting from the end.
That means, for each duplicate, the first occurrence will be the kept, and subsequent occurrences will be discarded.

TEST defaults to `equal'.

From Haskell."
  (declare (ignore start end key))
  (apply #'remove-duplicates seq :from-end t :test test args))

(define-compiler-macro nub (seq &rest args &key (test '#'equal) &allow-other-keys)
  `(remove-duplicates ,seq :from-end t :test ,test ,@args))

(defun gcp (seqs &key (test #'eql))
  "The greatest common prefix of SEQS.

If there is no common prefix, return NIL."
  (let ((test (ensure-function test)))
    (labels ((gcp (x y)
               (let ((miss (mismatch x y :test test)))
                 (cond ((not miss) x)
                       ((> miss 0) (subseq x 0 miss))
                       (t nil)))))
      (block nil
        (reduce
         (lambda (x y)
           (or (gcp x y)
               (return)))
         seqs)))))

(defun gcs (seqs &key (test #'eql))
  "The greatest common suffix of SEQS.

If there is no common suffix, return NIL."
  (let ((test (ensure-function test)))
    (labels ((gcs (x y)
               (let ((miss (mismatch x y :from-end t :test test)))
                 (cond ((not miss) x)
                       ((< miss (length x))
                        (subseq x miss))
                       (t nil)))))
      (block nil
        (reduce
         (lambda (x y)
           (or (gcs x y)
               (return)))
         seqs)))))

(-> of-length (array-length) function)
(defun of-length (length)
  "Return a predicate that returns T when called on a sequence of
length LENGTH.

    (funcall (of-length 3) '(1 2 3)) => t
    (funcall (of-length 1) '(1 2 3)) => nil"
  (lambda (seq)
    (sequence-of-length-p seq length)))

(define-compiler-macro of-length (&whole call length &environment env)
  (if (constantp length env)
      `(lambda (seq)
         (sequence-of-length-p seq ,length))
      call))

(defun length< (&rest seqs)
  "Is each length-designator in SEQS shorter than the next?
A length designator may be a sequence or an integer."
  (declare (dynamic-extent seqs))
  (apply #'length> (reverse seqs)))

(defun length> (&rest seqs)
  "Is each length-designator in SEQS longer than the next?
A length designator may be a sequence or an integer."
  (nlet rec ((last most-positive-fixnum)
             (seqs seqs))
    (if (endp seqs) t
        (destructuring-bind (seq . seqs) seqs
          (etypecase seq
            (array-length
             (and (> last seq)
                  (rec seq seqs)))
            (list
             (let ((len
                     ;; Get the length of SEQ, but only up to LAST.
                     (loop with len = 0
                           until (endp seq) do
                             (incf len)
                             (pop seq)
                           finally (return len))))
               (and (> last len)
                    (rec len seqs))))
            (sequence
             (let ((len (length seq)))
               (and (> last len)
                    (rec len seqs)))))))))

(defun length>= (&rest seqs)
  "Is each length-designator in SEQS longer or as long as the next?
A length designator may be a sequence or an integer."
  (not (apply #'length< seqs)))

(defun length<= (&rest seqs)
  "Is each length-designator in SEQS as long or shorter than the next?
A length designator may be a sequence or an integer."
  (not (apply #'length> seqs)))

(defun longer (x y)
  "Return the longer of X and Y.

If X and Y are of equal length, return X."
  (check-type x sequence)
  (check-type y sequence)
  (cond ((and (listp x) (listp y))
         (nlet longer ((xs x)
                       (ys y))
           (cond ((and (endp xs) (endp ys)) x)
                 ((endp ys) x)
                 ((endp xs) y)
                 (t (longer (rest xs) (rest ys))))))
        ((listp x)
         (if (length> x (length y))
             x
             y))
        ((listp y)
         (if (length> y (length x))
             y
             x))
        ((< (length x) (length y)) y)
        (t x)))

(-> longest (sequence) sequence)
(defun longest (seqs)
  "Return the longest seq in SEQS."
  (reduce #'longer seqs))

(-> shortest (sequence) sequence)
(defun shortest (seqs)
  "Return the shortest seq in SEQS."
  (reduce (lambda (x y)
            (if (eql (longer x y) x) y x))
          seqs))

(defsubst slice-bounds (len start end)
  "Normalize START and END, which may be negative, to offsets
acceptable to SUBSEQ."
  (declare (type signed-array-index start)
           (type signed-array-length end)
           (type array-index len))
  (let* ((start
           (if (minusp start)
               (max 0 (+ len start))
               (min start len)))
         (end
           (if (null end)
               nil
               (if (minusp end)
                   (max 0 (+ len end))
                   (min len end)))))
    (values start (max start end))))

(-> slice
    (sequence signed-array-index &optional (or null signed-array-length))
    sequence)
(defun slice (seq start &optional (end (length seq)))
  "Like `subseq', but allows negative bounds to specify offsets.
Both START and END accept negative bounds.

     (slice \"string\" -3 -1) => \"in\"

A call to `slice' where the first argument is positive and the second argument is negative is equivalent to chaining two calls to `drop':

    (drop 3 (drop -1 \"string\")) = \"in\"
    (slice \"string\" 3 -1)       = \"in\"

If the bounds cross in the middle, the result is an empty string:

    (slice \"x\" 1 -1) => \"\"

Setf of `slice' is like setf of `ldb': afterwards, the place being set
holds a new sequence which is not EQ to the old."
  (multiple-value-bind (start end)
      (slice-bounds (length seq) start end)
    (subseq seq start end)))

(defun setslice (seq1 seq2 start &optional end)
  "Helper to `set' a slice non-destructively."
  (multiple-value-bind (start end)
      (slice-bounds (length seq1) start end)
    (replace (copy-seq seq1) seq2 :start1 start :end1 end)))

(define-setf-expander slice (sequence start &optional end
                             &environment env)
  (multiple-value-bind (temps vals stores setter getter)
      (get-setf-expansion sequence env)
    (when (rest stores)
      (error "Can't expand"))
    (let ((stemp (first stores)))
      (with-gensyms (s e store)
        (values (list* s e temps)
                (list* start end vals)
                (list store)
                `(let ((,stemp (setslice ,getter ,store ,s ,e)))
                   ,setter
                   ,store)
                `(slice ,getter ,s ,e))))))

(defun ordering (seq &key unordered-to-end
                          from-end
                          (test 'eql)
                          (key #'identity))
  "Given a sequence, return a function that, when called with `sort',
restores the original order of the sequence.

That is, for any SEQ (without duplicates), it is always true that

     (equal seq (sort (reshuffle seq) (ordering seq)))

FROM-END controls what to do in case of duplicates. If FROM-END is
true, the last occurrence of each item is preserved; otherwise, only
the first occurrence counts.

TEST controls identity; it should be a valid test for a hash table. If
the items cannot be compared that way, you can use KEY to transform
them.

UNORDERED-TO-END controls where to sort items that are not present in
the original ordering. By default they are sorted first but, if
UNORDERED-TO-END is true, they are sorted last. In either case, they
are left in no particular order."
  (let ((table (make-hash-table :test test))
        (i -1))
    (with-item-key-function (key)
      (with-boolean (from-end)
        (do-each (item seq)
          (if from-end
              (setf (gethash (key item) table) (incf i))
              (ensure-gethash (key item) table (incf i)))))

      (let ((default
              (if unordered-to-end
                  (1+ i)
                  -1)))
        (declare (fixnum default))
        (lambda (x y)
          (< (gethash (key x) table default)
             (gethash (key y) table default)))))))

(-> take (signed-array-length sequence) sequence)
(defsubst take (n seq)
  "Return, at most, the first N elements of SEQ, as a *new* sequence
of the same type as SEQ.

If N is longer than SEQ, SEQ is simply copied.

If N is negative, then |N| elements are taken (in their original
order) from the end of SEQ."
  #+sbcl (declare (sb-ext:muffle-conditions style-warning))
  (declare (type signed-array-length n))
  (seq-dispatch seq
    (if (minusp n)
        (last seq (abs n))
        (firstn n seq))
    (if (minusp n)
        (subseq seq (max 0 (+ (length seq) n)))
        (subseq seq 0 (min n (length seq))))))

(-> drop (signed-array-length sequence) sequence)
(defsubst drop (n seq)
  "Return all but the first N elements of SEQ.
The sequence returned is a new sequence of the same type as SEQ.

If N is greater than the length of SEQ, returns an empty sequence of
the same type.

If N is negative, then |N| elements are dropped from the end of SEQ."
  #+sbcl (declare (sb-ext:muffle-conditions style-warning))
  (declare (type signed-array-length n))
  (seq-dispatch seq
    (if (minusp n)
        (butlast seq (abs n))
        (nthcdr n seq))
    (if (minusp n)
        (subseq seq 0 (max 0 (+ (length seq) n)))
        (subseq seq (min (length seq) n)))))

(-> take-while (function sequence) sequence)
(defsubst take-while (pred seq)
  "Return the prefix of SEQ for which PRED returns true."
  #+sbcl (declare (sb-ext:muffle-conditions style-warning))
  (seq-dispatch seq
    (ldiff seq (member-if-not pred seq))
    (subseq seq 0 (position-if-not pred seq))))

(-> drop-while (function sequence) sequence)
(defsubst drop-while (pred seq)
  "Return the largest possible suffix of SEQ for which PRED returns
false when called on the first element."
  #+sbcl (declare (sb-ext:muffle-conditions style-warning))
  (seq-dispatch seq
    (member-if-not pred seq)
    (subseq seq (position-if-not pred seq))))

(-> drop-prefix (sequence sequence &key (:test (or symbol function)))
  sequence)
(defun drop-prefix (prefix seq &key (test #'eql))
  "If SEQ starts with PREFIX, remove it."
  (cond ((emptyp prefix) seq)
        ((starts-with-subseq prefix seq :test test)
         (drop (length prefix) seq))
        (t seq)))

(-> ensure-prefix (sequence sequence &key (:test (or symbol function)))
  sequence)
(defun ensure-prefix (prefix seq &key (test #'eql))
  "Return a sequence like SEQ, but starting with PREFIX.
If SEQ already starts with PREFIX, return SEQ."
  (if (starts-with-subseq prefix seq :test test)
      seq
      (seq-dispatch seq
        (concatenate 'list prefix seq)
        (concatenate `(simple-array ,(array-element-type seq))
                     prefix seq)
        (concatenate (type-of seq) prefix seq))))

;;;# `bestn'
(defun bisect-left (vec item pred &key key)
  "Return the index in VEC to insert ITEM and keep VEC sorted."
  (declare ((simple-array * (*)) vec))
  (fbind (pred)
    (with-item-key-function (key)
      (let ((start 0)
            (end (length vec)))
        (declare (array-length start end))
        (let ((kitem (key item)))
          (loop while (< start end) do
            (let ((mid (floor (+ start end) 2)))
              (if (pred (key (svref vec mid)) kitem)
                  (setf start (1+ mid))
                  (setf end mid)))
                finally (return start)))))))

(defun bestn (n seq pred &key (key #'identity) memo)
  "Partial sorting.
Equivalent to (firstn N (sort SEQ PRED)), but much faster, at least
for small values of N.

With MEMO, use a decorate-sort-undecorate transform to ensure KEY is
only ever called once per element.

The name is from Arc."
  (declare (array-length n))
  (setf key (canonicalize-key key))
  (cond (memo
         (fbind (key)
           ;; Can't just copy SEQ, because it may not allow conses as
           ;; elements (e.g. octet vectors).
           (let* ((temp (map 'vector (op (cons (key _1) _1)) seq))
                  (bestn (bestn n temp pred :key #'car :memo nil))
                  (bestn (map-into bestn #'cdr bestn))
                  ;; The original sequence might have been shorter
                  ;; than N.
                  (out (make-sequence-like seq (length bestn))))
             (assert (length= bestn out))
             (replace out bestn))))
        ((= n 0)
         (make-sequence-like seq 0))
        ((= n 1)
         (make-sequence-like seq 1
                             :initial-contents (list (extremum seq pred :key key))))
        ((length<= seq n)
         (sort (copy-seq seq) pred :key key))
        (t (fbind ((test (complement pred)))
             (let ((heap (make-heap :size n
                                    :key key
                                    :test #'test))
                   (i 0))
               (declare (array-length i))
               (with-item-key-function (key)
                 (do-each (elt seq)
                   (locally (declare (optimize speed))
                     (cond ((< i n)
                            (heap-insert heap elt))
                           ((test (key (heap-maximum heap)) (key elt))
                            (heap-extract-maximum heap)
                            (heap-insert heap elt))))
                   (incf i)))
               (let ((bestn (take n (nreverse (heap-extract-all heap)))))
                 (make-sequence-like seq n :initial-contents bestn)))))))

(defun nth-best (n seq pred &key (key #'identity))
  "Return the Nth-best element of SEQ under PRED.

Equivalent to

    (elt (sort (copy-seq seq) pred) n)

Or even

    (elt (bestn (1+ n) seq pred) n)

But uses a selection algorithm for better performance than either."
  (nth-best! n
             (copy-sequence 'vector seq)
             pred
             :key key))

(defun nth-best! (n seq pred &key (key #'identity))
  "Destructive version of `nth-best'.
Note that this function requires that SEQ be a vector."
  (check-type n array-index)
  (check-type seq vector)
  (if (zerop n)
      (extremum seq pred :key key)
      (let* ((pred (ensure-function pred))
             (key  (ensure-function key))
             (pred (key-test key pred)))
        (quickselect seq n pred))))

(-> quickselect (vector array-index function) t)
(defun quickselect (a k lt)
  "Hoare's quickselect, as implemented by Wirth (\"FIND\"), with
  refinements by V. Zabrodsky (\"MODIFIND\")."
  (declare (optimize (debug 0) (safety 1)))
  (assert (< k (length a)))
  (fbind (lt)
    (with-vector-dispatch () a
      (loop with n = (length a)
            with l of-type array-index = 0
            with r of-type array-index = (1- n)
            for x = (vref a k)
            for i = l
            for j = r
            while (< l r) do
              (loop until (or (< j k) (< k i))
                    do (loop while (lt (vref a i) x) do (incf i))
                       (loop while (lt x (vref a j)) do (decf j))
                       (rotatef (vref a i) (vref a j))
                       (incf i)
                       (decf j))
              (when (< j k) (setf l i))
              (when (< k i) (setf r j))
            finally (return (vref a k))))))

(-> reshuffle (sequence &key (:element-type t))
    (values (simple-array * (*)) &optional))
(defun reshuffle (seq &key (element-type '*))
  "Like `alexandria:shuffle', but non-destructive.

Regardless of the type of SEQ, the return value is always a vector.

If ELEMENT-TYPE is provided, this is the element type (modulo
upgrading) of the vector returned.

If ELEMENT-TYPE is not provided, then the element type of the vector
returned is T, if SEQ is not a vector. If SEQ is a vector, then the
element type of the vector returned is the same as the as the element
type of SEQ."
  ;; TODO Would it be worthwhile to implement the "inside-out"
  ;; Fisher-Yates shuffle so we can shuffle and copy in one go?
  (shuffle (copy-sequence `(simple-array ,element-type (*))
                          seq)))

(-> sort-new (sequence function
                       &key
                       (:key (or function symbol))
                       (:element-type t))
    (simple-array * (*)))
(defun sort-new (seq pred &key (key #'identity)
                               (element-type '*))
  "Return a sorted vector of the elements of SEQ.

You can think of this as a non-destructive version of `sort', except
that it always returns a vector. (If you're going to copy a sequence
for the express purpose of sorting it, you might as well copy it into
a form that can be sorted efficiently.)

ELEMENT-TYPE is interpreted as for `reshuffle'."
  (sort (copy-sequence `(simple-array ,element-type (*))
                       seq)
        pred
        :key key))

(-> stable-sort-new (sequence function
                              &key
                              (:key (or function symbol))
                              (:element-type t))
    (simple-array * (*)))
(defun stable-sort-new (seq pred &key (key #'identity) (element-type '*))
  "Like `sort-new', but sort as if by `stable-sort' instead of `sort'."
  (stable-sort (copy-sequence `(simple-array ,element-type (*))
                              seq)
               pred
               :key key))

(defun extrema (seq pred &key (key #'identity) (start 0) end)
  "Like EXTREMUM, but returns both the minimum and the maximum (as two
values).

     (extremum (iota 10) #'>) => 9
     (extrema (iota 10) #'>) => 9, 0"
  (fbind (pred)
    (with-item-key-function (key)
      (let (min max kmin kmax (init t))
        (flet ((update-extrema (x)
                 (if init
                     (setf min x max x
                           kmin (key x)
                           kmax kmin
                           init nil)
                     (let ((kx (key x)))
                       (cond ((pred kx kmin)
                              (setf kmin kx min x))
                             ((pred kmax kx)
                              (setf kmax kx max x)))))))
          (declare (dynamic-extent #'update-extrema))
          (map-subseq #'update-extrema seq start end))
        (values min max)))))

(-> split-at (list array-index) (values list list))
(defun split-at (list k)
  (declare (list list)
           (optimize speed))
  (nlet rec ((left '())
             (right list)
             (k k))
    (declare (array-index k))
    (if (zerop k)
        (values (nreverse left) right)
        (rec (cons (car right) left)
             (cdr right)
             (1- k)))))

(-> halves
    (sequence &optional (or null signed-array-index))
    (values sequence sequence))
(defun halves (seq &optional split)
  "Return, as two values, the first and second halves of SEQ.
SPLIT designates where to split SEQ; it defaults to half the length,
but can be specified.

If SPLIT is not provided, the length is halved using `ceiling' rather
than `truncate'. This is on the theory that, if SEQ is a
single-element list, it should be returned unchanged.

If SPLIT is negative, then the split is determined by counting |split|
elements from the right (or, equivalently, length+split elements from
the left."
  (declare ((or null signed-array-index) split))
  (flet ((halfway-point (seq)
           (ceiling (length seq) 2)))
    (seq-dispatch seq
      (if split
          (if (minusp split)
              (split-at seq (max 0 (+ (length seq) split)))
              ;; If we know where to split in advance we only have to
              ;; traverse the list once.
              (split-at seq split))
          (split-at seq (halfway-point seq)))
      (let* ((len (length seq))
             (split (or (and split
                             (clamp
                              (if (minusp split)
                                  (+ len split)
                                  split)
                              0 len))
                        (halfway-point seq))))
        (values (subseq seq 0 split)
                (subseq seq split))))))

(defun dsu-sort (seq fn &key (key #'identity) stable)
  "Decorate-sort-undecorate using KEY.
Useful when KEY is an expensive function (e.g. database access)."
  (let ((vec (dsu-sort-new seq fn :key key :stable stable)))
    (assert (length= vec seq))
    (replace seq vec)))

(defun dsu-sort-new (seq fn &key (key #'identity) stable)
  "Like `dsu-sort', but returning a new vector."
  (let* ((vec
           ;; Vectors sort faster.
           (map 'vector
                (with-item-key-function (key)
                  (lambda (item)
                    (cons (key item) item)))
                seq))
         (vec
           (funcall (if stable #'stable-sort #'sort)
                    vec fn
                    :key #'car)))
    (map-into vec #'cdr vec)))

(defun deltas (seq &optional (fn #'-))
  "Return the successive differences in SEQ.

     (deltas '(4 9 -5 1 2))
     => '(4 5 -14 6 1)

Note that the first element of SEQ is also the first element of the
return value.

By default, the delta is the difference, but you can specify another
function as a second argument:

    (deltas '(2 4 2 6) #'/)
    => '(2 2 1/2 3)

From Q."
  (let ((fn (ensure-function fn)))
    (seq-dispatch seq
      (cons (car seq)
            (mapcar fn (cdr seq) seq))
      (and (> (length seq) 0)
           (cons (elt seq 0)
                 (map 'list fn (nsubseq seq 1) seq))))))

(defcondition inconsistent-graph (error)
  ((constraints :initarg :constraints
                :reader inconsistent-graph-constraints
                :documentation "The offending constraints"))
  (:documentation "A graph that cannot be consistently sorted.")
  (:report (lambda (self stream)
             (format stream
                     "Inconsistent graph: ~a"
                     (inconsistent-graph-constraints self)))))

(setf (documentation 'inconsistent-graph-constraints 'function)
      "The constraints of an `inconsistent-graph' error.
Cf. `toposort'.")

(defun default-tie-breaker (min-elts constraints)
  "The default tie breaker for a topological sort."
  (declare (ignore constraints))
  (first min-elts))

(defun tsort (elts constraints tie-breaker &key (test #'eql))
  "Do the initial topological sort."
  (declare (function test tie-breaker))
  (loop while elts
        for min-elts = (or (remove-if
                            (lambda (x)
                              (member x constraints
                                      :key #'second
                                      :test test))
                            elts)
                           (if (null elts)
                               (loop-finish)
                               (error 'inconsistent-graph
                                      :constraints constraints)))
        for choice = (if (null (rest min-elts))
                         (first min-elts)
                         (funcall tie-breaker min-elts (reverse results)))
        do (removef elts choice :test test)
           (removef constraints choice
                    :test
                    (lambda (x ys)
                      (member x ys :test test)))
        collect choice into results
        finally (return results)))

(defun toposort (constraints
                 &key (test #'eql)
                      (tie-breaker #'default-tie-breaker)
                      from-end unordered-to-end)
  "Turn CONSTRAINTS into a predicate for use with SORT.

Each constraint should be two-element list, where the first element of
the list should come before the second element of the list.

    (def dem-bones '((toe foot)
                     (foot heel)
                     (heel ankle)
                     (ankle shin)
                     (shin knee)
                     (knee back)
                     (back shoulder)
                     (shoulder neck)
                     (neck head)))
    (sort (reshuffle (mapcar #'car dem-bones))
          (toposort dem-bones))
    => (TOE FOOT HEEL ANKLE SHIN KNEE BACK SHOULDER NECK)

If the graph is inconsistent, signals an error of type
`inconsistent-graph`:

    (toposort '((chicken egg) (egg chicken)))
    => Inconsistent graph: ((CHICKEN EGG) (EGG CHICKEN))

TEST, FROM-END, and UNORDERED-TO-END are passed through to
`ordering'."
  ;; Adapted from AMOP.
  (let ((elts (remove-duplicates (flatten constraints) :test test)))
    (ordering (tsort elts constraints tie-breaker :test test)
              :test test
              :unordered-to-end unordered-to-end
              :from-end from-end)))

(defun intersperse/list (new-elt list)
  (loop for (item . rest) on list
        if (null rest)
          collect item
        else collect item
             and collect new-elt))

(defun intersperse/seq (new-elt seq)
  (if (< (length seq) 2)
      (copy-seq seq)
      (let* ((len1 (length seq))
             (len2 (1- (* 2 len1)))
             (ret (make-sequence-like seq len2))
             (j 0))
        (loop for i below len2 do
          (if (oddp i)
              (setf (elt ret i) new-elt)
              (progn
                (setf (elt ret i) (elt seq j))
                (incf j))))
        ret)))

(-> intersperse (t sequence) (values sequence &optional))
(defsubst intersperse (new-elt seq)
  "Return a sequence like SEQ, but with NEW-ELT inserted between each
element."
  #+sbcl (declare (sb-ext:muffle-conditions style-warning))
  (seq-dispatch seq
    (intersperse/list new-elt seq)
    (intersperse/seq new-elt seq)))

(defun mvfold-aux (fn seq seeds &optional from-end)
  (cond ((null seeds)
         (reduce fn seq :from-end from-end))
        ((null (rest seeds))
         (reduce fn seq :from-end from-end
                        :initial-value (first seeds)))
        (t (let ((fn (ensure-function fn)))
             (values-list
              (reduce (lambda (l r)
                        ;; We use `replace' so the function is always
                        ;; called with the right number of values.
                        (replace (fill (copy-list seeds) nil)
                                 (multiple-value-list
                                  (if from-end
                                      (apply fn l r)
                                      (multiple-value-call fn
                                        (values-list l)
                                        r)))))
                      seq
                      :initial-value seeds
                      :from-end from-end))))))

(defun mvfold (fn seq &rest seeds)
  "Like `reduce' extended to multiple values.

Calling `mvfold' with one seed is equivalent to `reduce':

    (mvfold fn xs seed) ≡ (reduce fn xs :initial-value seed)

However, you can also call `mvfold' with multiple seeds:

    (mvfold fn xs seed1 seed2 seed3 ...)

How is this useful? Consider extracting the minimum of a sequence:

    (reduce #'min xs)

Or the maximum:

    (reduce #'max xs)

But both?

    (reduce (lambda (cons item)
              (cons (min (car cons) item)
                    (max (cdr cons) item)))
            xs
            :initial-value (cons (elt xs 0) (elt xs 0)))

You can do this naturally with `mvfold'.

    (mvfold (lambda (min max item)
              (values (min item min)
                      (max item max)))
            xs (elt xs 0) (elt xs 0))

In general `mvfold' provides a functional idiom for “loops with
book-keeping” where we might otherwise have to use recursion or
explicit iteration.

Has a compiler macro that generates efficient code when the number of
SEEDS is fixed at compile time (as it usually is)."
  (mvfold-aux fn seq seeds))

(defun mvfoldr (fn seq &rest seeds)
  "Like `(reduce FN SEQ :from-end t)' extended to multiple
values. Cf. `mvfold'."
  (mvfold-aux fn seq seeds t))

(eval-when (:compile-toplevel :load-toplevel)
  (defun expand-mvfold (fn seq seeds &optional from-end)
    (cond ((null seeds)
           `(reduce ,fn ,seq :from-end ,from-end))
          ((null (cdr seeds))
           `(reduce ,fn ,seq
                    :from-end ,from-end
                    :initial-value ,(car seeds)))
          (t (let ((tmps (make-gensym-list (length seeds))))
               (with-gensyms (item)
                 (rebinding-functions (fn)
                   `(let ,(mapcar #'list tmps seeds)
                      ,(if from-end
                           `(do-subseq (,item ,seq (values ,@tmps) :from-end t)
                              (setf (values ,@tmps)
                                    (funcall ,fn ,item ,@tmps)))
                           `(do-each (,item ,seq (values ,@tmps))
                              (setf (values ,@tmps)
                                    (funcall ,fn ,@tmps ,item))))))))))))

(define-compiler-macro mvfold (fn seq &rest seeds)
  "Optimize `mvfold' with a fixed number of seeds."
  (expand-mvfold fn seq seeds))

(define-compiler-macro mvfoldr (fn seq &rest seeds)
  "Optimize `mvfoldr' with a fixed number of seeds."
  (expand-mvfold fn seq seeds t))

;;; The obvious signature:
;;; (-> repeat-sequence (sequence array-length) sequence)
;;; is not used because N could be any positive integer as long as
;;; SEQUENCE is empty.

(-> repeat-sequence (sequence (integer 0 *))
    (values sequence &optional))
(defun repeat-sequence (seq n)
  "Return a sequence like SEQ, with the same content, but repeated N times.

    (repeat-sequence \"13\" 3)
    => \"131313\"

The length of the sequence returned will always be the length of SEQ
times N.

This means that 0 repetitions results in an empty sequence:

    (repeat-sequence \"13\" 0)
    => \"\"

Conversely, N may be greater than the possible length of a sequence,
as long as SEQ is empty.

    (repeat-sequence \"\" (1+ array-dimension-limit))
    => \"\"
"
  (check-type n (integer 0 *))
  (seq-dispatch seq
    (repeat-list seq n)
    (repeat-vector seq n)
    (let ((len (length seq)))
      (if (zerop len)
          (make-sequence-like seq 0)
          (loop with out = (make-sequence-like seq (* len n))
                repeat n
                for offset from 0 by (length seq)
                do (replace out seq :start1 offset)
                finally (return out))))))

(define-compiler-macro repeat-sequence (&whole call seq n &environment env)
  (multiple-value-bind (seq constant?)
      (eval-if-constant seq env)
    (if (not constant?) call
        (match seq
          ((string c)
           `(make-string ,n
                         :initial-element ,c
                         :element-type ',(array-element-type seq)))
          ((vector x)
           `(make-array (list ,n)
                        :initial-element ,x
                        :element-type ',(array-element-type seq)))
          ((list x)
           `(make-list ,n :initial-element ',x))
          (otherwise call)))))

(defun repeat-list (list n)
  (declare (optimize speed (safety 0)))
  (if (null list) nil
      (let ((n (assure array-index n)))
        (collecting*
          (loop repeat n do
            (loop for item in list do
              (collect item)))))))

(defun repeat-vector (vec n)
  (declare (type vector vec)
           (optimize (safety 0) (debug 0)))
  (when (= (length vec) 0)
    (return-from repeat-vector
      (make-array 0 :element-type (array-element-type vec))))
  (unless (< (* (length vec) n) array-dimension-limit)
    (error "A vector of size ~a*~a is too big" (length vec) n))
  (let* ((len (length vec))
         (n n)
         (len-out (* len n)))
    (declare (array-index len n len-out))
    (with-simple-vector-dispatch
        (simple-bit-vector (simple-array character (*)))
        (vec from to)
      (let ((out (make-array len-out :element-type (array-element-type vec))))
        (nlet rec ((n n) (offset from))
          (declare (array-index n offset))
          (if (zerop n)
              out
              (progn
                (replace out vec :start1 offset :start2 from :end2 to)
                (rec (1- n) (+ offset len)))))))))

(labels ((%seq= (x y)
           (or (equal x y)
               (and (typep x 'sequence)
                    (typep y 'sequence)
                    (length= x y)
                    (every #'%seq= x y)))))

  (-> seq=/2 (t t) boolean)
  (defun seq=/2 (x y)
    (%seq= x y))

  (-> seq= (&rest t) boolean)
  (defun seq= (&rest xs)
    "Like `equal', but recursively compare sequences element-by-element.

Two elements X and Y are `seq=' if they are `equal', or if they are
both sequences of the same length and their elements are all `seq='."
    (declare (dynamic-extent xs))
    (match xs
      ((list) t)
      ((list _) t)
      (otherwise
       (loop for x in xs
             for y in (rest xs)
             always (%seq= x y))))))

(define-compiler-macro seq= (&whole call &rest xs)
  (match xs
    ((list) t)
    ((list x) `(progn ,x t))
    ((list x y) `(seq=/2 ,x ,y))
    (otherwise call)))

(defun map-splits (fn split-fn seq start end from-end)
  (if from-end
      (map-splits-from-end fn split-fn seq start end)
      (map-splits-from-start fn split-fn seq start end)))

(defun map-splits-from-start (fn split-fn seq start end)
  (fbind (fn)
    (let ((start (or start 0))
          (end (or end (length seq))))
      (loop with len = (length seq)
            for left = start then (1+ right)
            for right = (min (or (position-if split-fn seq
                                              :start left)
                                 len)
                             end)
            do (fn left right (/= right end))
            until (>= right end)))))

(defun map-splits-from-end (fn split-fn seq start end)
  (fbind (fn)
    (loop
      for right = end then left
      for left = (max (or (position-if split-fn
                                       seq
                                       :end right
                                       :from-end t)
                          -1)
                      (1- start))
      collect (fn left right (/= right end))
      until (< left start))))

(define-do-macro do-splits (((left right &optional not-at-end?)
                             (seq split-fn &key (start 0) end from-end)
                             &optional return)
                            &body body)
  "For each run of elements in SEQ that does not satisfy SPLIT-FN, call the body with LEFT bound to the start of the run and RIGHT bound to the end of the run.

If `split-sequence-if' did not exist, you could define a simple version trivially with `do-splits' and `collecting':

    (defun split-sequence-if (fn seq &key (start 0) end from-end)
      (collecting
        (do-splits ((l r) (seq fn :start start :end end :from-end from-end))
          (collect (subseq seq l r)))))

Providing NOT-AT-END? will bind it as a variable that is T if RIGHT is
not equal to END, and null otherwise. This can be useful when, in
processing a sequence, you want to replace existing delimiters, but do
nothing at the end.

In general `do-splits' will be found useful in situations where you
want to iterate over subsequences in the manner of `split-sequence',
but don't actually need to realize the sequences."
  (let ((c (or not-at-end? (gensym))))
    (with-unique-names (fn)
      `(flet ((,fn (,left ,right &optional ,c)
                (declare
                 (type array-index ,left)
                 (type array-length ,right)
                 (type boolean ,c)
                 ,@(unsplice (unless not-at-end? `(ignorable ,c))))
                ,@body))
         (declare (dynamic-extent #',fn))
         (map-splits #',fn ,split-fn ,seq ,start ,end ,from-end)))))

(defun list-collapse-duplicates (test key list)
  (declare (list list))
  (with-test-fn (test)
    (with-item-key-function (key)
      (nlet rec ((list list)
                 (acc '())
                 (last-result nil))
        (if (endp list) (nreverse acc)
            (if (null acc)
                (rec (cdr list)
                     (cons (car list) acc)
                     (key (car list)))
                (let ((new-result (key (car list))))
                  (if (test last-result new-result)
                      (rec (cdr list) acc last-result)
                      (rec (cdr list)
                           (cons (car list) acc)
                           new-result)))))))))

(defun collapse-duplicates (seq &key (key #'identity) (test #'eql))
  "Remove adjacent duplicates in SEQ.

Repetitions that are not adjacent are left alone.

    (remove-duplicates '(1 1 2 2 1 1)) => '(1 2)
    (collapse-duplicates  '(1 1 2 2 1 1)) => '(1 2 1)"
  (if (listp seq)
      (list-collapse-duplicates test key seq)
      (with-test-fn (test)
        (with-item-key-function (key)
          (with-specialized-buckets (seq)
            (let ((bucket (make-bucket seq))
                  (len (length seq)))
              (nlet rec ((i 0)
                         (last-key nil))
                (cond ((= i len)
                       (bucket-seq seq bucket))
                      ((= i 0)
                       (let ((elt (elt seq 0)))
                         (bucket-push seq elt bucket)
                         (rec 1 (key elt))))
                      (t
                       (let* ((elt (elt seq i))
                              (new-key (key elt)))
                         (if (test new-key last-key)
                             (rec (1+ i) last-key)
                             (progn
                               (bucket-push seq elt bucket)
                               (rec (1+ i) new-key)))))))))))))