555 lines
		
	
	
	
		
			24 KiB
		
	
	
	
		
			Common Lisp
		
	
	
	
	
	
			
		
		
	
	
			555 lines
		
	
	
	
		
			24 KiB
		
	
	
	
		
			Common Lisp
		
	
	
	
	
	
(in-package :alexandria)
 | 
						|
 | 
						|
;; Make these inlinable by declaiming them INLINE here and some of them
 | 
						|
;; NOTINLINE at the end of the file. Exclude functions that have a compiler
 | 
						|
;; macro, because NOTINLINE is required to prevent compiler-macro expansion.
 | 
						|
(declaim (inline copy-sequence sequence-of-length-p))
 | 
						|
 | 
						|
(defun sequence-of-length-p (sequence length)
 | 
						|
  "Return true if SEQUENCE is a sequence of length LENGTH. Signals an error if
 | 
						|
SEQUENCE is not a sequence. Returns FALSE for circular lists."
 | 
						|
  (declare (type array-index length)
 | 
						|
           #-lispworks (inline length)
 | 
						|
           (optimize speed))
 | 
						|
  (etypecase sequence
 | 
						|
    (null
 | 
						|
     (zerop length))
 | 
						|
    (cons
 | 
						|
     (let ((n (1- length)))
 | 
						|
       (unless (minusp n)
 | 
						|
         (let ((tail (nthcdr n sequence)))
 | 
						|
           (and tail
 | 
						|
                (null (cdr tail)))))))
 | 
						|
    (vector
 | 
						|
     (= length (length sequence)))
 | 
						|
    (sequence
 | 
						|
     (= length (length sequence)))))
 | 
						|
 | 
						|
(defun rotate-tail-to-head (sequence n)
 | 
						|
  (declare (type (integer 1) n))
 | 
						|
  (if (listp sequence)
 | 
						|
      (let ((m (mod n (proper-list-length sequence))))
 | 
						|
        (if (null (cdr sequence))
 | 
						|
            sequence
 | 
						|
            (let* ((tail (last sequence (+ m 1)))
 | 
						|
                   (last (cdr tail)))
 | 
						|
              (setf (cdr tail) nil)
 | 
						|
              (nconc last sequence))))
 | 
						|
      (let* ((len (length sequence))
 | 
						|
             (m (mod n len))
 | 
						|
             (tail (subseq sequence (- len m))))
 | 
						|
        (replace sequence sequence :start1 m :start2 0)
 | 
						|
        (replace sequence tail)
 | 
						|
        sequence)))
 | 
						|
 | 
						|
(defun rotate-head-to-tail (sequence n)
 | 
						|
  (declare (type (integer 1) n))
 | 
						|
  (if (listp sequence)
 | 
						|
      (let ((m (mod (1- n) (proper-list-length sequence))))
 | 
						|
        (if (null (cdr sequence))
 | 
						|
            sequence
 | 
						|
            (let* ((headtail (nthcdr m sequence))
 | 
						|
                   (tail (cdr headtail)))
 | 
						|
              (setf (cdr headtail) nil)
 | 
						|
              (nconc tail sequence))))
 | 
						|
      (let* ((len (length sequence))
 | 
						|
             (m (mod n len))
 | 
						|
             (head (subseq sequence 0 m)))
 | 
						|
        (replace sequence sequence :start1 0 :start2 m)
 | 
						|
        (replace sequence head :start1 (- len m))
 | 
						|
        sequence)))
 | 
						|
 | 
						|
(defun rotate (sequence &optional (n 1))
 | 
						|
  "Returns a sequence of the same type as SEQUENCE, with the elements of
 | 
						|
SEQUENCE rotated by N: N elements are moved from the end of the sequence to
 | 
						|
the front if N is positive, and -N elements moved from the front to the end if
 | 
						|
N is negative. SEQUENCE must be a proper sequence. N must be an integer,
 | 
						|
defaulting to 1.
 | 
						|
 | 
						|
If absolute value of N is greater then the length of the sequence, the results
 | 
						|
are identical to calling ROTATE with
 | 
						|
 | 
						|
  (* (signum n) (mod n (length sequence))).
 | 
						|
 | 
						|
Note: the original sequence may be destructively altered, and result sequence may
 | 
						|
share structure with it."
 | 
						|
  (if (plusp n)
 | 
						|
      (rotate-tail-to-head sequence n)
 | 
						|
      (if (minusp n)
 | 
						|
          (rotate-head-to-tail sequence (- n))
 | 
						|
          sequence)))
 | 
						|
 | 
						|
(defun shuffle (sequence &key (start 0) end)
 | 
						|
  "Returns a random permutation of SEQUENCE bounded by START and END.
 | 
						|
Original sequence may be destructively modified, and (if it contains
 | 
						|
CONS or lists themselv) share storage with the original one.
 | 
						|
Signals an error if SEQUENCE is not a proper sequence."
 | 
						|
  (declare (type fixnum start)
 | 
						|
           (type (or fixnum null) end))
 | 
						|
  (etypecase sequence
 | 
						|
    (list
 | 
						|
     (let* ((end (or end (proper-list-length sequence)))
 | 
						|
            (n (- end start)))
 | 
						|
       (do ((tail (nthcdr start sequence) (cdr tail)))
 | 
						|
           ((zerop n))
 | 
						|
         (rotatef (car tail) (car (nthcdr (random n) tail)))
 | 
						|
         (decf n))))
 | 
						|
    (vector
 | 
						|
     (let ((end (or end (length sequence))))
 | 
						|
       (loop for i from start below end
 | 
						|
             do (rotatef (aref sequence i)
 | 
						|
                         (aref sequence (+ i (random (- end i))))))))
 | 
						|
    (sequence
 | 
						|
     (let ((end (or end (length sequence))))
 | 
						|
       (loop for i from (- end 1) downto start
 | 
						|
             do (rotatef (elt sequence i)
 | 
						|
                         (elt sequence (+ i (random (- end i)))))))))
 | 
						|
  sequence)
 | 
						|
 | 
						|
(defun random-elt (sequence &key (start 0) end)
 | 
						|
  "Returns a random element from SEQUENCE bounded by START and END. Signals an
 | 
						|
error if the SEQUENCE is not a proper non-empty sequence, or if END and START
 | 
						|
are not proper bounding index designators for SEQUENCE."
 | 
						|
  (declare (sequence sequence) (fixnum start) (type (or fixnum null) end))
 | 
						|
  (let* ((size (if (listp sequence)
 | 
						|
                   (proper-list-length sequence)
 | 
						|
                   (length sequence)))
 | 
						|
         (end2 (or end size)))
 | 
						|
    (cond ((zerop size)
 | 
						|
           (error 'type-error
 | 
						|
                  :datum sequence
 | 
						|
                  :expected-type `(and sequence (not (satisfies emptyp)))))
 | 
						|
          ((not (and (<= 0 start) (< start end2) (<= end2 size)))
 | 
						|
           (error 'simple-type-error
 | 
						|
                  :datum (cons start end)
 | 
						|
                  :expected-type `(cons (integer 0 (,end2))
 | 
						|
                                        (or null (integer (,start) ,size)))
 | 
						|
                  :format-control "~@<~S and ~S are not valid bounding index designators for ~
 | 
						|
                                   a sequence of length ~S.~:@>"
 | 
						|
                  :format-arguments (list start end size)))
 | 
						|
          (t
 | 
						|
           (let ((index (+ start (random (- end2 start)))))
 | 
						|
             (elt sequence index))))))
 | 
						|
 | 
						|
(declaim (inline remove/swapped-arguments))
 | 
						|
(defun remove/swapped-arguments (sequence item &rest keyword-arguments)
 | 
						|
  (apply #'remove item sequence keyword-arguments))
 | 
						|
 | 
						|
(define-modify-macro removef (item &rest keyword-arguments)
 | 
						|
  remove/swapped-arguments
 | 
						|
  "Modify-macro for REMOVE. Sets place designated by the first argument to
 | 
						|
the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS.")
 | 
						|
 | 
						|
(declaim (inline delete/swapped-arguments))
 | 
						|
(defun delete/swapped-arguments (sequence item &rest keyword-arguments)
 | 
						|
  (apply #'delete item sequence keyword-arguments))
 | 
						|
 | 
						|
(define-modify-macro deletef (item &rest keyword-arguments)
 | 
						|
  delete/swapped-arguments
 | 
						|
  "Modify-macro for DELETE. Sets place designated by the first argument to
 | 
						|
the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS.")
 | 
						|
 | 
						|
(deftype proper-sequence ()
 | 
						|
  "Type designator for proper sequences, that is proper lists and sequences
 | 
						|
that are not lists."
 | 
						|
  `(or proper-list
 | 
						|
       (and (not list) sequence)))
 | 
						|
 | 
						|
(eval-when (:compile-toplevel :load-toplevel :execute)
 | 
						|
  (when (and (find-package '#:sequence)
 | 
						|
             (find-symbol (string '#:emptyp) '#:sequence))
 | 
						|
    (pushnew 'sequence-emptyp *features*)))
 | 
						|
 | 
						|
#-alexandria::sequence-emptyp
 | 
						|
(defun emptyp (sequence)
 | 
						|
  "Returns true if SEQUENCE is an empty sequence. Signals an error if SEQUENCE
 | 
						|
is not a sequence."
 | 
						|
  (etypecase sequence
 | 
						|
    (list (null sequence))
 | 
						|
    (sequence (zerop (length sequence)))))
 | 
						|
 | 
						|
#+alexandria::sequence-emptyp
 | 
						|
(declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
 | 
						|
#+alexandria::sequence-emptyp
 | 
						|
(setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
 | 
						|
#+alexandria::sequence-emptyp
 | 
						|
(define-compiler-macro emptyp (sequence)
 | 
						|
  `(sequence:emptyp ,sequence))
 | 
						|
 | 
						|
(defun length= (&rest sequences)
 | 
						|
  "Takes any number of sequences or integers in any order. Returns true iff
 | 
						|
the length of all the sequences and the integers are equal. Hint: there's a
 | 
						|
compiler macro that expands into more efficient code if the first argument
 | 
						|
is a literal integer."
 | 
						|
  (declare (dynamic-extent sequences)
 | 
						|
           (inline sequence-of-length-p)
 | 
						|
           (optimize speed))
 | 
						|
  (unless (cdr sequences)
 | 
						|
    (error "You must call LENGTH= with at least two arguments"))
 | 
						|
  ;; There's room for optimization here: multiple list arguments could be
 | 
						|
  ;; traversed in parallel.
 | 
						|
  (let* ((first (pop sequences))
 | 
						|
         (current (if (integerp first)
 | 
						|
                      first
 | 
						|
                      (length first))))
 | 
						|
    (declare (type array-index current))
 | 
						|
    (dolist (el sequences)
 | 
						|
      (if (integerp el)
 | 
						|
          (unless (= el current)
 | 
						|
            (return-from length= nil))
 | 
						|
          (unless (sequence-of-length-p el current)
 | 
						|
            (return-from length= nil)))))
 | 
						|
  t)
 | 
						|
 | 
						|
(define-compiler-macro length= (&whole form length &rest sequences)
 | 
						|
  (cond
 | 
						|
    ((zerop (length sequences))
 | 
						|
     form)
 | 
						|
    (t
 | 
						|
     (let ((optimizedp (integerp length)))
 | 
						|
       (with-unique-names (tmp current)
 | 
						|
         (declare (ignorable current))
 | 
						|
         `(locally
 | 
						|
              (declare (inline sequence-of-length-p))
 | 
						|
            (let ((,tmp)
 | 
						|
                  ,@(unless optimizedp
 | 
						|
                     `((,current ,length))))
 | 
						|
              ,@(unless optimizedp
 | 
						|
                  `((unless (integerp ,current)
 | 
						|
                      (setf ,current (length ,current)))))
 | 
						|
              (and
 | 
						|
               ,@(loop
 | 
						|
                    :for sequence :in sequences
 | 
						|
                    :collect `(progn
 | 
						|
                                (setf ,tmp ,sequence)
 | 
						|
                                (if (integerp ,tmp)
 | 
						|
                                    (= ,tmp ,(if optimizedp
 | 
						|
                                                 length
 | 
						|
                                                 current))
 | 
						|
                                    (sequence-of-length-p ,tmp ,(if optimizedp
 | 
						|
                                                                    length
 | 
						|
                                                                    current)))))))))))))
 | 
						|
 | 
						|
(defun copy-sequence (type sequence)
 | 
						|
  "Returns a fresh sequence of TYPE, which has the same elements as
 | 
						|
SEQUENCE."
 | 
						|
  (if (typep sequence type)
 | 
						|
      (copy-seq sequence)
 | 
						|
      (coerce sequence type)))
 | 
						|
 | 
						|
(defun first-elt (sequence)
 | 
						|
  "Returns the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 | 
						|
not a sequence, or is an empty sequence."
 | 
						|
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
 | 
						|
  ;; type-error.
 | 
						|
  (cond  ((consp sequence)
 | 
						|
          (car sequence))
 | 
						|
         ((and (typep sequence 'sequence) (not (emptyp sequence)))
 | 
						|
          (elt sequence 0))
 | 
						|
         (t
 | 
						|
          (error 'type-error
 | 
						|
                 :datum sequence
 | 
						|
                 :expected-type '(and sequence (not (satisfies emptyp)))))))
 | 
						|
 | 
						|
(defun (setf first-elt) (object sequence)
 | 
						|
  "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE is
 | 
						|
not a sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 | 
						|
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
 | 
						|
  ;; type-error.
 | 
						|
  (cond ((consp sequence)
 | 
						|
         (setf (car sequence) object))
 | 
						|
        ((and (typep sequence 'sequence) (not (emptyp sequence)))
 | 
						|
         (setf (elt sequence 0) object))
 | 
						|
        (t
 | 
						|
         (error 'type-error
 | 
						|
                :datum sequence
 | 
						|
                :expected-type '(and sequence (not (satisfies emptyp)))))))
 | 
						|
 | 
						|
(defun last-elt (sequence)
 | 
						|
  "Returns the last element of SEQUENCE. Signals a type-error if SEQUENCE is
 | 
						|
not a proper sequence, or is an empty sequence."
 | 
						|
  ;; Can't just directly use ELT, as it is not guaranteed to signal the
 | 
						|
  ;; type-error.
 | 
						|
  (let ((len 0))
 | 
						|
    (cond ((consp sequence)
 | 
						|
           (lastcar sequence))
 | 
						|
          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 | 
						|
           (elt sequence (1- len)))
 | 
						|
          (t
 | 
						|
           (error 'type-error
 | 
						|
                  :datum sequence
 | 
						|
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 | 
						|
 | 
						|
(defun (setf last-elt) (object sequence)
 | 
						|
  "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE is not a proper
 | 
						|
sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
 | 
						|
  (let ((len 0))
 | 
						|
    (cond ((consp sequence)
 | 
						|
           (setf (lastcar sequence) object))
 | 
						|
          ((and (typep sequence '(and sequence (not list))) (plusp (setf len (length sequence))))
 | 
						|
           (setf (elt sequence (1- len)) object))
 | 
						|
          (t
 | 
						|
           (error 'type-error
 | 
						|
                  :datum sequence
 | 
						|
                  :expected-type '(and proper-sequence (not (satisfies emptyp))))))))
 | 
						|
 | 
						|
(defun starts-with-subseq (prefix sequence &rest args
 | 
						|
                           &key
 | 
						|
                           (return-suffix nil return-suffix-supplied-p)
 | 
						|
                           &allow-other-keys)
 | 
						|
  "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
 | 
						|
 | 
						|
If RETURN-SUFFIX is T the function returns, as a second value, a
 | 
						|
sub-sequence or displaced array pointing to the sequence after PREFIX."
 | 
						|
  (declare (dynamic-extent args))
 | 
						|
  (let ((sequence-length (length sequence))
 | 
						|
        (prefix-length (length prefix)))
 | 
						|
    (when (< sequence-length prefix-length)
 | 
						|
      (return-from starts-with-subseq (values nil nil)))
 | 
						|
    (flet ((make-suffix (start)
 | 
						|
             (when return-suffix
 | 
						|
               (cond
 | 
						|
                 ((not (arrayp sequence))
 | 
						|
                  (if start
 | 
						|
                      (subseq sequence start)
 | 
						|
                      (subseq sequence 0 0)))
 | 
						|
                 ((not start)
 | 
						|
                  (make-array 0
 | 
						|
                              :element-type (array-element-type sequence)
 | 
						|
                              :adjustable nil))
 | 
						|
                 (t
 | 
						|
                  (make-array (- sequence-length start)
 | 
						|
                              :element-type (array-element-type sequence)
 | 
						|
                              :displaced-to sequence
 | 
						|
                              :displaced-index-offset start
 | 
						|
                              :adjustable nil))))))
 | 
						|
      (let ((mismatch (apply #'mismatch prefix sequence
 | 
						|
                             (if return-suffix-supplied-p
 | 
						|
                                 (remove-from-plist args :return-suffix)
 | 
						|
                                 args))))
 | 
						|
        (cond
 | 
						|
          ((not mismatch)
 | 
						|
           (values t (make-suffix nil)))
 | 
						|
          ((= mismatch prefix-length)
 | 
						|
           (values t (make-suffix mismatch)))
 | 
						|
          (t
 | 
						|
           (values nil nil)))))))
 | 
						|
 | 
						|
(defun ends-with-subseq (suffix sequence &key (test #'eql))
 | 
						|
  "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
 | 
						|
the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
 | 
						|
  (let ((sequence-length (length sequence))
 | 
						|
        (suffix-length (length suffix)))
 | 
						|
    (when (< sequence-length suffix-length)
 | 
						|
      ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
 | 
						|
      (return-from ends-with-subseq nil))
 | 
						|
    (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
 | 
						|
          for suffix-index from 0 below suffix-length
 | 
						|
          when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
 | 
						|
          do (return-from ends-with-subseq nil)
 | 
						|
          finally (return t))))
 | 
						|
 | 
						|
(defun starts-with (object sequence &key (test #'eql) (key #'identity))
 | 
						|
  "Returns true if SEQUENCE is a sequence whose first element is EQL to OBJECT.
 | 
						|
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
 | 
						|
  (let ((first-elt (typecase sequence
 | 
						|
                     (cons (car sequence))
 | 
						|
                     (sequence
 | 
						|
                      (if (emptyp sequence)
 | 
						|
                          (return-from starts-with nil)
 | 
						|
                          (elt sequence 0)))
 | 
						|
                     (t
 | 
						|
                      (return-from starts-with nil)))))
 | 
						|
    (funcall test (funcall key first-elt) object)))
 | 
						|
 | 
						|
(defun ends-with (object sequence &key (test #'eql) (key #'identity))
 | 
						|
  "Returns true if SEQUENCE is a sequence whose last element is EQL to OBJECT.
 | 
						|
Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. Signals
 | 
						|
an error if SEQUENCE is an improper list."
 | 
						|
  (let ((last-elt (typecase sequence
 | 
						|
                    (cons
 | 
						|
                     (lastcar sequence)) ; signals for improper lists
 | 
						|
                    (sequence
 | 
						|
                     ;; Can't use last-elt, as that signals an error
 | 
						|
                     ;; for empty sequences
 | 
						|
                     (let ((len (length sequence)))
 | 
						|
                       (if (plusp len)
 | 
						|
                           (elt sequence (1- len))
 | 
						|
                           (return-from ends-with nil))))
 | 
						|
                    (t
 | 
						|
                     (return-from ends-with nil)))))
 | 
						|
    (funcall test (funcall key last-elt) object)))
 | 
						|
 | 
						|
(defun map-combinations (function sequence &key (start 0) end length (copy t))
 | 
						|
  "Calls FUNCTION with each combination of LENGTH constructable from the
 | 
						|
elements of the subsequence of SEQUENCE delimited by START and END. START
 | 
						|
defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
 | 
						|
delimited subsequence. (So unless LENGTH is specified there is only a single
 | 
						|
combination, which has the same elements as the delimited subsequence.) If
 | 
						|
COPY is true (the default) each combination is freshly allocated. If COPY is
 | 
						|
false all combinations are EQ to each other, in which case consequences are
 | 
						|
unspecified if a combination is modified by FUNCTION."
 | 
						|
  (let* ((end (or end (length sequence)))
 | 
						|
         (size (- end start))
 | 
						|
         (length (or length size))
 | 
						|
         (combination (subseq sequence 0 length))
 | 
						|
         (function (ensure-function function)))
 | 
						|
    (if (= length size)
 | 
						|
        (funcall function combination)
 | 
						|
        (flet ((call ()
 | 
						|
                 (funcall function (if copy
 | 
						|
                                       (copy-seq combination)
 | 
						|
                                       combination))))
 | 
						|
          (etypecase sequence
 | 
						|
            ;; When dealing with lists we prefer walking back and
 | 
						|
            ;; forth instead of using indexes.
 | 
						|
            (list
 | 
						|
             (labels ((combine-list (c-tail o-tail)
 | 
						|
                        (if (not c-tail)
 | 
						|
                            (call)
 | 
						|
                            (do ((tail o-tail (cdr tail)))
 | 
						|
                                ((not tail))
 | 
						|
                              (setf (car c-tail) (car tail))
 | 
						|
                              (combine-list (cdr c-tail) (cdr tail))))))
 | 
						|
               (combine-list combination (nthcdr start sequence))))
 | 
						|
            (vector
 | 
						|
             (labels ((combine (count start)
 | 
						|
                        (if (zerop count)
 | 
						|
                            (call)
 | 
						|
                            (loop for i from start below end
 | 
						|
                                  do (let ((j (- count 1)))
 | 
						|
                                       (setf (aref combination j) (aref sequence i))
 | 
						|
                                       (combine j (+ i 1)))))))
 | 
						|
               (combine length start)))
 | 
						|
            (sequence
 | 
						|
             (labels ((combine (count start)
 | 
						|
                        (if (zerop count)
 | 
						|
                            (call)
 | 
						|
                            (loop for i from start below end
 | 
						|
                                  do (let ((j (- count 1)))
 | 
						|
                                       (setf (elt combination j) (elt sequence i))
 | 
						|
                                       (combine j (+ i 1)))))))
 | 
						|
               (combine length start)))))))
 | 
						|
  sequence)
 | 
						|
 | 
						|
(defun map-permutations (function sequence &key (start 0) end length (copy t))
 | 
						|
  "Calls function with each permutation of LENGTH constructable
 | 
						|
from the subsequence of SEQUENCE delimited by START and END. START
 | 
						|
defaults to 0, END to length of the sequence, and LENGTH to the
 | 
						|
length of the delimited subsequence."
 | 
						|
  (let* ((end (or end (length sequence)))
 | 
						|
         (size (- end start))
 | 
						|
         (length (or length size)))
 | 
						|
    (labels ((permute (seq n)
 | 
						|
               (let ((n-1 (- n 1)))
 | 
						|
                 (if (zerop n-1)
 | 
						|
                     (funcall function (if copy
 | 
						|
                                           (copy-seq seq)
 | 
						|
                                           seq))
 | 
						|
                     (loop for i from 0 upto n-1
 | 
						|
                           do (permute seq n-1)
 | 
						|
                           (if (evenp n-1)
 | 
						|
                               (rotatef (elt seq 0) (elt seq n-1))
 | 
						|
                               (rotatef (elt seq i) (elt seq n-1)))))))
 | 
						|
             (permute-sequence (seq)
 | 
						|
               (permute seq length)))
 | 
						|
      (if (= length size)
 | 
						|
          ;; Things are simple if we need to just permute the
 | 
						|
          ;; full START-END range.
 | 
						|
          (permute-sequence (subseq sequence start end))
 | 
						|
          ;; Otherwise we need to generate all the combinations
 | 
						|
          ;; of LENGTH in the START-END range, and then permute
 | 
						|
          ;; a copy of the result: can't permute the combination
 | 
						|
          ;; directly, as they share structure with each other.
 | 
						|
          (let ((permutation (subseq sequence 0 length)))
 | 
						|
            (flet ((permute-combination (combination)
 | 
						|
                     (permute-sequence (replace permutation combination))))
 | 
						|
              (declare (dynamic-extent #'permute-combination))
 | 
						|
              (map-combinations #'permute-combination sequence
 | 
						|
                                :start start
 | 
						|
                                :end end
 | 
						|
                                :length length
 | 
						|
                                :copy nil)))))))
 | 
						|
 | 
						|
(defun map-derangements (function sequence &key (start 0) end (copy t))
 | 
						|
  "Calls FUNCTION with each derangement of the subsequence of SEQUENCE denoted
 | 
						|
by the bounding index designators START and END. Derangement is a permutation
 | 
						|
of the sequence where no element remains in place. SEQUENCE is not modified,
 | 
						|
but individual derangements are EQ to each other. Consequences are unspecified
 | 
						|
if calling FUNCTION modifies either the derangement or SEQUENCE."
 | 
						|
  (let* ((end (or end (length sequence)))
 | 
						|
         (size (- end start))
 | 
						|
         ;; We don't really care about the elements here.
 | 
						|
         (derangement (subseq sequence 0 size))
 | 
						|
         ;; Bitvector that has 1 for elements that have been deranged.
 | 
						|
         (mask (make-array size :element-type 'bit :initial-element 0)))
 | 
						|
    (declare (dynamic-extent mask))
 | 
						|
    ;; ad hoc algorith
 | 
						|
    (labels ((derange (place n)
 | 
						|
               ;; Perform one recursive step in deranging the
 | 
						|
               ;; sequence: PLACE is index of the original sequence
 | 
						|
               ;; to derange to another index, and N is the number of
 | 
						|
               ;; indexes not yet deranged.
 | 
						|
               (if (zerop n)
 | 
						|
                   (funcall function (if copy
 | 
						|
                                         (copy-seq derangement)
 | 
						|
                                         derangement))
 | 
						|
                   ;; Itarate over the indexes I of the subsequence to
 | 
						|
                   ;; derange: if I != PLACE and I has not yet been
 | 
						|
                   ;; deranged by an earlier call put the element from
 | 
						|
                   ;; PLACE to I, mark I as deranged, and recurse,
 | 
						|
                   ;; finally removing the mark.
 | 
						|
                   (loop for i from 0 below size
 | 
						|
                         do
 | 
						|
                         (unless (or (= place (+ i start)) (not (zerop (bit mask i))))
 | 
						|
                           (setf (elt derangement i) (elt sequence place)
 | 
						|
                                 (bit mask i) 1)
 | 
						|
                           (derange (1+ place) (1- n))
 | 
						|
                           (setf (bit mask i) 0))))))
 | 
						|
      (derange start size)
 | 
						|
      sequence)))
 | 
						|
 | 
						|
(declaim (notinline sequence-of-length-p))
 | 
						|
 | 
						|
(defun extremum (sequence predicate &key key (start 0) end)
 | 
						|
  "Returns the element of SEQUENCE that would appear first if the subsequence
 | 
						|
bounded by START and END was sorted using PREDICATE and KEY.
 | 
						|
 | 
						|
EXTREMUM determines the relationship between two elements of SEQUENCE by using
 | 
						|
the PREDICATE function. PREDICATE should return true if and only if the first
 | 
						|
argument is strictly less than the second one (in some appropriate sense). Two
 | 
						|
arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
 | 
						|
and (FUNCALL PREDICATE Y X) are both false.
 | 
						|
 | 
						|
The arguments to the PREDICATE function are computed from elements of SEQUENCE
 | 
						|
using the KEY function, if supplied. If KEY is not supplied or is NIL, the
 | 
						|
sequence element itself is used.
 | 
						|
 | 
						|
If SEQUENCE is empty, NIL is returned."
 | 
						|
  (let* ((pred-fun (ensure-function predicate))
 | 
						|
         (key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
 | 
						|
                    (ensure-function key)))
 | 
						|
         (real-end (or end (length sequence))))
 | 
						|
    (cond ((> real-end start)
 | 
						|
           (if key-fun
 | 
						|
               (flet ((reduce-keys (a b)
 | 
						|
                        (if (funcall pred-fun
 | 
						|
                                     (funcall key-fun a)
 | 
						|
                                     (funcall key-fun b))
 | 
						|
                            a
 | 
						|
                            b)))
 | 
						|
                 (declare (dynamic-extent #'reduce-keys))
 | 
						|
                 (reduce #'reduce-keys sequence :start start :end real-end))
 | 
						|
               (flet ((reduce-elts (a b)
 | 
						|
                        (if (funcall pred-fun a b)
 | 
						|
                            a
 | 
						|
                            b)))
 | 
						|
                 (declare (dynamic-extent #'reduce-elts))
 | 
						|
                 (reduce #'reduce-elts sequence :start start :end real-end))))
 | 
						|
          ((= real-end start)
 | 
						|
           nil)
 | 
						|
          (t
 | 
						|
           (error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
 | 
						|
                  (length sequence)
 | 
						|
                  :start start
 | 
						|
                  :end end)))))
 |