556 lines
24 KiB
Common Lisp
556 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)))))
|