diff options
Diffstat (limited to 'third_party/lisp/alexandria/sequences.lisp')
| -rw-r--r-- | third_party/lisp/alexandria/sequences.lisp | 555 |
1 files changed, 0 insertions, 555 deletions
diff --git a/third_party/lisp/alexandria/sequences.lisp b/third_party/lisp/alexandria/sequences.lisp deleted file mode 100644 index 21464f5376..0000000000 --- a/third_party/lisp/alexandria/sequences.lisp +++ /dev/null @@ -1,555 +0,0 @@ -(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))))) |