summaryrefslogtreecommitdiff
path: root/Sacla/sequence.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Sacla/sequence.lisp')
-rw-r--r--Sacla/sequence.lisp677
1 files changed, 677 insertions, 0 deletions
diff --git a/Sacla/sequence.lisp b/Sacla/sequence.lisp
new file mode 100644
index 0000000..07b6684
--- /dev/null
+++ b/Sacla/sequence.lisp
@@ -0,0 +1,677 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: sequence.lisp,v 1.42 2004/02/20 07:23:42 yuji Exp $
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; * Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; * Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in
+;; the documentation and/or other materials provided with the
+;; distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(defun length (sequence)
+ "Return the number of elements in SEQUENCE."
+ (cond ;; can't use etypecase for setf
+ ((typep sequence 'list)
+ (let ((length (list-length sequence)))
+ (or length (error-circular-list sequence))))
+ ((typep sequence 'vector)
+ (if (array-has-fill-pointer-p sequence)
+ (fill-pointer sequence)
+ (array-dimension sequence 0)))
+ (t
+ (error 'type-error :datum sequence :expected-type 'sequence))))
+
+(defun check-sequence-access (sequence index)
+ (check-type sequence proper-sequence)
+ (check-type index (integer 0))
+ (unless (< index (length sequence))
+ (error-index-too-large sequence index)))
+
+(defun check-subsequence (sequence start end)
+ (check-type sequence proper-sequence)
+ (check-type start (integer 0))
+ (check-type end (integer 0)))
+
+(defun elt (sequence index)
+ "Return the element of SEQUENCE specified by INDEX."
+ (check-sequence-access sequence index)
+ (if (consp sequence)
+ (nth index sequence)
+ (aref sequence index)))
+
+(defsetf elt (sequence index) (value)
+ "Set the element of SEQUENCE specified by INDEX."
+ (let ((seq (gensym))
+ (idx (gensym)))
+ `(let ((,seq ,sequence)
+ (,idx ,index))
+ (check-sequence-access ,seq ,idx)
+ (if (consp ,seq)
+ (progn (rplaca (nthcdr ,idx ,seq) ,value) ,value)
+ (setf (aref ,seq ,idx) ,value)))))
+
+(defun reverse (sequence)
+ "Return a new sequence containing the same elements but in reverse order."
+ (check-type sequence proper-sequence)
+ (cond
+ ((null sequence) nil)
+ ((consp sequence) (do ((x sequence (cdr x))
+ (result nil (cons (car x) result)))
+ ((null x) result)))
+ (t (let* ((length (length sequence))
+ (result (make-array length
+ :element-type (array-element-type sequence))))
+ (do ((i 0 (1+ i))
+ (j (1- length) (1- j)))
+ ((>= i length) result)
+ (setf (aref result i) (aref sequence j)))))))
+
+(defun nreverse (sequence)
+ "Modyfy SEQUENCE so that the elements are in reverse order."
+ (check-type sequence proper-sequence)
+ (cond
+ ((null sequence) nil)
+ ((consp sequence) (do ((1st (cdr sequence) (cdr 1st))
+ (2nd sequence 1st)
+ (3rd '() 2nd))
+ ((null 2nd) 3rd)
+ (rplacd 2nd 3rd)))
+ (t (let ((length (length sequence)))
+ (do ((i 0 (1+ i))
+ (j (1- length) (1- j)))
+ ((>= i j) sequence)
+ (rotatef (aref sequence i) (aref sequence j)))))))
+
+(defun count-if (predicate sequence &key from-end (start 0) end key)
+ "Count the number of elements in SEQUENCE which satisfy PREDICATE."
+ (let ((count 0))
+ (do-subsequence (element sequence start end from-end count)
+ (when (funcall predicate (apply-key key element))
+ (incf count)))))
+
+(defun count-if-not (predicate sequence &key from-end (start 0) end key)
+ "Count the number of elements in SEQUENCE which do not satisfy PREDICATE."
+ (count-if (complement predicate)
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun count (item sequence
+ &key from-end (start 0) end key (test #'eql) test-not)
+ "Count the number of ITEM in SEQUENCE bounded by START and END."
+ (when test-not (setq test (complement test-not)))
+ (count-if #'(lambda (arg) (funcall test item arg))
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun find-if (predicate sequence &key from-end (start 0) end key)
+ "Return the first element in SEQUENCE satisfying PREDICATE."
+ (do-subsequence (element sequence start end from-end nil)
+ (when (funcall predicate (apply-key key element))
+ (return element))))
+
+(defun find-if-not (predicate sequence &key from-end (start 0) end key)
+ "Return the first element in SEQUENCE not satisfying PREDICATE."
+ (find-if (complement predicate) sequence
+ :from-end from-end :start start :end end :key key))
+
+(defun find (item sequence
+ &key from-end (test #'eql) test-not (start 0) end key)
+ "Return the first element in SEQUENCE satisfying TEST or TEST-NOT."
+ (when test-not (setq test (complement test-not)))
+ (find-if #'(lambda (arg) (funcall test item arg))
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun position-if (predicate sequence &key from-end (start 0) end key)
+ "Return the position of an element in SEQUENCE satisfying PREDICATE."
+ (unless end (setq end (length sequence)))
+ (let ((i (if from-end (1- end) start))
+ (step (if from-end -1 1)))
+ (do-subsequence (element sequence start end from-end nil)
+ (when (funcall predicate (apply-key key element))
+ (return i))
+ (incf i step))))
+
+(defun position-if-not (predicate sequence &key from-end (start 0) end key)
+ "Return the position of an element in SEQUENCE not satisfying PREDICATE."
+ (position-if (complement predicate) sequence
+ :from-end from-end :start start :end end :key key))
+
+(defun position (item sequence
+ &key from-end (test #'eql) test-not (start 0) end key)
+ "Return the position of an element in SEQUENCE equal to ITEM by TEST."
+ (when test-not (setq test (complement test-not)))
+ (position-if #'(lambda (arg) (funcall test item arg))
+ sequence :from-end from-end :start start :end end :key key))
+
+(defun make-iterator (sequence start end length from-end)
+ (check-subsequence sequence start end)
+ (if (listp sequence)
+ (let* ((head (if from-end
+ (nthcdr (- length end) (reverse sequence))
+ (nthcdr start sequence)))
+ (x head))
+ (values #'(lambda () (prog1 (car x) (setq x (cdr x))))
+ #'(lambda () (setq x head))))
+ (let* ((from (if from-end (1- end) start))
+ (i from)
+ (step (if from-end -1 1)))
+ (values #'(lambda () (prog1 (aref sequence i) (setq i (+ i step))))
+ #'(lambda () (setq i from))))))
+
+(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not key
+ (start1 0) (start2 0) end1 end2)
+ "Return the first position in SEQUENCE2 that matches SEQUENCE1."
+ (when test-not (setq test (complement test-not)))
+ (let* ((length1 (length sequence1))
+ (end1 (or end1 length1))
+ (end2 (or end2 (length sequence2)))
+ (width1 (- end1 start1))
+ (last-match nil))
+ (multiple-value-bind (get1 reset1)
+ (make-iterator sequence1 start1 end1 length1 nil)
+ (etypecase sequence2
+ (null (when (zerop length1) 0))
+ (cons (do ((x (nthcdr start2 sequence2) (cdr x))
+ (i start2 (1+ i)))
+ ((> i (- end2 width1)) (when from-end last-match))
+ (funcall reset1)
+ (do ((xx x (cdr xx))
+ (j 0 (1+ j)))
+ ((>= j width1) (if from-end
+ (setq last-match i)
+ (return-from search i)))
+ (unless (funcall test (apply-key key (funcall get1))
+ (apply-key key (car xx)))
+ (return)))))
+ (vector (do ((i start2 (1+ i)))
+ ((> i (- end2 width1)) (when from-end last-match))
+ (funcall reset1)
+ (do ((ii i (1+ ii))
+ (j 0 (1+ j)))
+ ((>= j width1) (if from-end
+ (setq last-match i)
+ (return-from search i)))
+ (unless (funcall test (apply-key key (funcall get1))
+ (apply-key key (aref sequence2 ii)))
+ (return)))))))))
+
+(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not key
+ (start1 0) (start2 0) end1 end2)
+ "Return the first position where SEQUENCE1 and SEQUENCE2 differ."
+ (when test-not (setq test (complement test-not)))
+ (let* ((length1 (length sequence1))
+ (length2 (length sequence2))
+ (end1 (or end1 length1))
+ (end2 (or end2 length2))
+ (width1 (- end1 start1))
+ (width2 (- end2 start2))
+ (width (min width1 width2))
+ (s1 (if from-end (- end1 width) start1))
+ (e1 (if from-end end1 (+ start1 width))))
+ (multiple-value-bind (get2 reset2)
+ (make-iterator sequence2 start2 end2 length2 from-end)
+ (declare (ignore reset2))
+ (let ((i1 (if from-end (1- end1) start1))
+ (step (if from-end -1 1)))
+ (do-subsequence (element1 sequence1 s1 e1 from-end
+ (cond ((= width1 width2) nil)
+ ((< width1 width2) (if from-end 0 end1))
+ (t (if from-end
+ (- end1 width2)
+ (+ start1 width2)))))
+ (unless (funcall test (apply-key key element1)
+ (apply-key key (funcall get2)))
+ (return (if from-end (1+ i1) i1)))
+ (incf i1 step))))))
+
+(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
+ "Modify SEQUENCE1 destructively by replacing elements with those of SUBSEQUENCE2."
+ (let* ((length2 (length sequence2))
+ (end1 (or end1 (length sequence1)))
+ (end2 (or end2 length2))
+ (width1 (- end1 start1))
+ (width2 (- end2 start2))
+ (width (min width1 width2))
+ (from-end nil))
+ (when (< start2 start1 (+ start2 width))
+ (setq sequence2 (copy-seq sequence2)))
+ (multiple-value-bind (get2 reset2)
+ (make-iterator sequence2 start2 end2 length2 from-end)
+ (declare (ignore reset2))
+ (do-subsequence (element1 sequence1 start1 (+ start1 width) from-end)
+ (setf element1 (funcall get2)))
+ sequence1)))
+
+
+(defun subseq (sequence start &optional end)
+ "Return a copy of the subsequence of SEQUENCE bounded by START and END."
+ (unless end (setq end (length sequence)))
+ (check-subsequence sequence start end)
+ (etypecase sequence
+ (list (do* ((x (nthcdr start sequence) (cdr x))
+ (i start (1+ i))
+ (result (list nil))
+ (splice result))
+ ((>= i end) (cdr result))
+ (setq splice (cdr (rplacd splice (list (car x)))))))
+ (vector (let* ((width (- end start))
+ (result (make-array width
+ :element-type
+ (array-element-type sequence))))
+ (do ((i 0 (1+ i))
+ (j start (1+ j)))
+ ((>= i width) result)
+ (setf (aref result i) (aref sequence j)))))))
+
+(defsetf subseq (sequence start &optional (end nil)) (new-subsequence)
+ "Replace destructively the subsequence of SEQUENCE with NEW-SUBSEQUENCE."
+ `(progn
+ (check-type ,new-subsequence sequence)
+ (replace ,sequence ,new-subsequence :start1 ,start :end1 ,end)
+ ,new-subsequence))
+
+(defun copy-seq (sequence)
+ "Create a copy of SEQUENCE."
+ (subseq sequence 0))
+
+(defun nsubstitute-if (newitem predicate sequence &key from-end
+ (start 0) end count key)
+ "Modify SEQUENCE substituting NEWITEM for elements satisfying PREDICATE."
+ (when (or (null count) (plusp count))
+ (do-subsequence (element sequence start end from-end)
+ (when (funcall predicate (apply-key key element))
+ (setf element newitem)
+ (when (and count (zerop (setq count (1- count))))
+ (return)))))
+ sequence)
+
+(defun nsubstitute (newitem olditem sequence &key from-end (test #'eql) test-not
+ (start 0) end count key)
+ "Modify SEQUENCE substituting NEWITEM for elements euqal to OLDITEM."
+ (when test-not (setq test (complement test-not)))
+ (nsubstitute-if newitem #'(lambda (item) (funcall test olditem item))
+ sequence :from-end from-end :start start :end end
+ :count count :key key))
+
+(defun nsubstitute-if-not (newitem predicate sequence &key from-end
+ (start 0) end count key)
+ "Modify SEQUENCE substituting NEWITEM for elements not satisfying PREDICATE."
+ (nsubstitute-if newitem (complement predicate) sequence :from-end from-end
+ :start start :end end :count count :key key))
+
+(defun substitute (newitem olditem sequence &key from-end (test #'eql) test-not
+ (start 0) end count key)
+ "Return a copy of SEQUENCE with elements euqal to OLDITEM replaced with NEWITEM."
+ (nsubstitute newitem olditem (copy-seq sequence) :from-end from-end :test test
+ :test-not test-not :start start :end end :count count :key key))
+
+(defun substitute-if (newitem predicate sequence &key from-end (start 0) end
+ count key)
+ "Return a copy of SEQUENCE with elements satisfying PREDICATE replaced with NEWITEM."
+ (nsubstitute-if newitem predicate (copy-seq sequence) :from-end from-end
+ :start start :end end :count count :key key))
+
+(defun substitute-if-not (newitem predicate sequence &key from-end (start 0) end
+ count key)
+ "Return a copy of SEQUENCE with elements not satisfying PREDICATE replaced with NEWITEM."
+ (nsubstitute-if-not newitem predicate (copy-seq sequence) :from-end from-end
+ :start start :end end :count count :key key))
+
+(defun fill (sequence item &key (start 0) end)
+ "Replace the elements of SEQUENCE bounded by START and END with ITEM."
+ (nsubstitute-if item (constantly t) sequence :start start :end end))
+
+(defun concatenate (result-type &rest sequences)
+ "Return a sequence of RESULT-TYPE that have all the elements of SEQUENCES."
+ (cond
+ ((subtypep result-type 'list)
+ (let* ((list (list nil))
+ (splice list))
+ (dolist (seq sequences (cdr list))
+ (do-subsequence (element seq 0)
+ (setq splice (cdr (rplacd splice (cons element nil))))))))
+ ((subtypep result-type 'vector)
+ (let ((vector (make-sequence result-type
+ (apply #'+ (mapcar #'length sequences))))
+ (i 0))
+ (dolist (seq sequences vector)
+ (do-subsequence (element seq 0)
+ (setf (aref vector i) element)
+ (incf i)))))
+ (t
+ (error 'type-error
+ :datum result-type
+ :expected-type '(or null sequence)))))
+
+(defun merge-lists (list1 list2 predicate key)
+ (let* ((list (list nil))
+ (splice list))
+ (do ((x1 list1)
+ (x2 list2))
+ ((or (endp x1) (endp x2)) (rplacd splice (or x1 x2)) (cdr list))
+ (if (funcall predicate (apply-key key (car x2))
+ (apply-key key (car x1)))
+ (setq splice (cdr (rplacd splice x2))
+ x2 (cdr x2))
+ (setq splice (cdr (rplacd splice x1))
+ x1 (cdr x1))))))
+
+(defun merge (result-type sequence1 sequence2 predicate &key key)
+ "Merge SEQUENCE1 with SEQUENCE2 destructively according to an order determined by the PREDICATE."
+ (let ((merged-list (merge-lists (coerce sequence1 'list)
+ (coerce sequence2 'list) predicate key)))
+ (cond ((subtypep result-type 'list) merged-list)
+ ((subtypep result-type 'vector) (coerce merged-list result-type))
+ (t (error 'type-error
+ :datum result-type
+ :expected-type '(or null sequence))))))
+
+(defun quicksort-vector (vector predicate key)
+ (labels ((quicksort (left right)
+ (if (<= right left)
+ vector
+ (let ((v (partition left right)))
+ (quicksort left (1- v))
+ (quicksort (1+ v) right))))
+ (partition (left right)
+ (let ((pivot (apply-key key (aref vector right)))
+ (l left)
+ (r (1- right)))
+ (loop (loop (unless (funcall predicate
+ (apply-key key (aref vector l))
+ pivot)
+ (return))
+ (incf l))
+ (loop (when (or (>= l r)
+ (funcall predicate
+ (apply-key key (aref vector r))
+ pivot))
+ (return))
+ (decf r))
+ (when (>= l r)
+ (return))
+ (rotatef (aref vector l) (aref vector r)))
+ (rotatef (aref vector l) (aref vector right))
+ l)))
+ (quicksort 0 (1- (length vector)))))
+
+(defun sort (sequence predicate &key key)
+ "Sort SEQUENCE destructively according to the order determined by PREDICATE."
+ (if (vectorp sequence)
+ (quicksort-vector sequence predicate key)
+ (let ((vector (quicksort-vector (make-array (length sequence)
+ :initial-contents sequence)
+ predicate key)))
+ (do ((x sequence (cdr x))
+ (i 0 (1+ i)))
+ ((endp x) sequence)
+ (rplaca x (aref vector i))))))
+
+(defun mergesort-list (list predicate key)
+ (labels ((mergesort (list length)
+ (if (<= length 1)
+ list
+ (let* ((length1 (floor (/ length 2)))
+ (length2 (- length length1))
+ (list1 list)
+ (last1 (nthcdr (1- length1) list))
+ (list2 (cdr last1)))
+ (rplacd last1 nil)
+ (merge 'list
+ (mergesort list1 length1) (mergesort list2 length2)
+ predicate :key key)))))
+ (mergesort list (length list))))
+
+(defun stable-sort (sequence predicate &key key)
+ "Sort SEQUENCE destructively guaranteeing the stability of equal elements' order."
+ (if (listp sequence)
+ (mergesort-list sequence predicate key)
+ (let ((list (mergesort-list (coerce sequence 'list) predicate key)))
+ (do ((x list (cdr x))
+ (i 0 (1+ i)))
+ ((endp x) sequence)
+ (setf (aref sequence i) (car x))))))
+
+(defun list-delete-if (test list start end count key)
+ (let* ((head (cons nil list))
+ (splice head))
+ (do ((i 0 (1+ i))
+ (x list (cdr x)))
+ ((endp x) (rplacd splice nil) (cdr head))
+ (when (and count (<= count 0))
+ (rplacd splice x)
+ (return (cdr head)))
+ (if (and (<= start i) (or (null end) (< i end))
+ (funcall test (apply-key key (car x))))
+ (when count (decf count))
+ (setq splice (cdr (rplacd splice x)))))))
+
+(defun vector-delete-if (test vector start end count key)
+ (let* ((length (length vector))
+ (end (or end length))
+ (count (or count length))
+ (i 0))
+ (do* ((j 0 (1+ j))
+ element)
+ ((>= j length))
+ (setq element (aref vector j))
+ (if (and (<= start j) (< j end)
+ (plusp count)
+ (funcall test (apply-key key element)))
+ (when count (decf count))
+ (progn
+ (setf (aref vector i) element)
+ (incf i))))
+ (cond
+ ((array-has-fill-pointer-p vector)
+ (setf (fill-pointer vector) i)
+ vector)
+ ((adjustable-array-p vector) (adjust-array vector i))
+ (t (subseq vector 0 i)))))
+
+(defun delete-if (predicate sequence &key from-end (start 0) end count key)
+ "Modify SEQUENCE by deleting elements satisfying PREDICATE."
+ (if from-end
+ (let ((length (length sequence)))
+ (nreverse (delete-if predicate (nreverse sequence)
+ :start (- length (or end length))
+ :end (- length start)
+ :count count :key key)))
+ (etypecase sequence
+ (null nil)
+ (cons (list-delete-if predicate sequence start end count key))
+ (vector (vector-delete-if predicate sequence start end count key)))))
+
+(defun delete (item sequence &key from-end (test #'eql) test-not (start 0) end
+ count key)
+ "Modify SEQUENCE by deleting elements equal to ITEM."
+ (when test-not (setq test (complement test-not)))
+ (delete-if #'(lambda (arg) (funcall test item arg)) sequence
+ :from-end from-end :start start :end end :count count :key key))
+
+(defun delete-if-not (predicate sequence &key from-end (start 0) end count key)
+ "Modify SEQUENCE by deleting elements not satisfying PREDICATE."
+ (delete-if (complement predicate) sequence :from-end from-end
+ :start start :end end :count count :key key))
+
+(defun remove-if (predicate sequence &key from-end (start 0) end count key)
+ "Return a copy of SEQUENCE with elements satisfying PREDICATE removed."
+ (delete-if predicate (copy-seq sequence) :from-end from-end :start start :end end
+ :count count :key key))
+
+(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
+ end count key)
+ "Return a copy of SEQUENCE with elements equal to ITEM removed."
+ (when test-not (setq test (complement test-not)))
+ (remove-if #'(lambda (arg) (funcall test item arg)) sequence
+ :from-end from-end :start start :end end :count count :key key))
+
+(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
+ "Return a copy of SEQUENCE with elements not satisfying PREDICATE removed."
+ (remove-if (complement predicate) sequence :from-end from-end
+ :start start :end end :count count :key key))
+
+
+(defun list-delete-duplicates (test list start end key)
+ (check-type list proper-list)
+ (let* ((head (cons nil list))
+ (splice head)
+ (tail (when end (nthcdr end list))))
+ (flet ((list-member (list)
+ (do ((x (cdr list) (cdr x))
+ (item (car list)))
+ ((eq x tail) nil)
+ (when (funcall test (apply-key key item) (apply-key key (car x)))
+ (return t)))))
+ (do ((i 0 (1+ i))
+ (x list (cdr x)))
+ ((endp x) (rplacd splice nil) (cdr head))
+ (unless (and (<= start i) (or (null end) (< i end)) (list-member x))
+ (setq splice (cdr (rplacd splice x))))))))
+
+(defun vector-delete-duplicates (test vector start end key)
+ (let* ((length (length vector))
+ (end (or end length))
+ (i 0))
+ (flet ((vector-member (item j)
+ (do ((k (1+ j) (1+ k)))
+ ((>= k end) nil)
+ (when (funcall test (apply-key key item)
+ (apply-key key (aref vector k)))
+ (return t)))))
+ (do* ((j 0 (1+ j))
+ element)
+ ((>= j length))
+ (setq element (aref vector j))
+ (unless (and (<= start j) (< j end) (vector-member element j))
+ (setf (aref vector i) element)
+ (incf i)))
+ (cond
+ ((array-has-fill-pointer-p vector)
+ (setf (fill-pointer vector) i)
+ vector)
+ ((adjustable-array-p vector) (adjust-array vector i))
+ (t (subseq vector 0 i))))))
+
+(defun delete-duplicates (sequence &key from-end (test #'eql) test-not
+ (start 0) end key)
+ "Modify SEQUENCE deleting redundant elements."
+ (when test-not (setq test (complement test-not)))
+ (if from-end
+ (let ((length (length sequence)))
+ (nreverse (delete-duplicates (nreverse sequence) :test test :key key
+ :start (- length (or end length))
+ :end (- length start))))
+ (etypecase sequence
+ (null nil)
+ (cons (list-delete-duplicates test sequence start end key))
+ (vector (vector-delete-duplicates test sequence start end key)))))
+
+(defun remove-duplicates (sequence &key from-end (test #'eql) test-not
+ (start 0) end key)
+ "Return a copy of SEQUENCE with redundant elements removed."
+ (delete-duplicates (copy-seq sequence) :from-end from-end :key key
+ :test test :test-not test-not :start start :end end))
+
+(defun reduce (function sequence &key key from-end (start 0) end
+ (initial-value nil initial-value-supplied))
+ "Use a binary operation FUNCTION to combine the elements of SEQUENCE."
+ (unless end (setq end (length sequence)))
+ (check-subsequence sequence start end)
+ (if (= start end)
+ (if initial-value-supplied initial-value (funcall function))
+ (let ((fun (if from-end #'(lambda (a b) (funcall function b a)) function))
+ (value (if initial-value-supplied
+ initial-value
+ (apply-key key (if from-end
+ (elt sequence (decf end))
+ (prog1 (elt sequence start)
+ (incf start)))))))
+ (do-subsequence (element sequence start end from-end value)
+ (setq value (funcall fun value (apply-key key element)))))))
+
+(defmacro do-sequences ((var sequences &optional (result nil)) &body body)
+ (let ((seq-list (gensym))
+ (i (gensym))
+ (min (gensym)))
+ `(let* ((,seq-list (copy-seq ,sequences))
+ (,var (make-list (list-length ,seq-list) :initial-element nil))
+ (,min (if ,seq-list (reduce #'min ,seq-list :key #'length) 0)))
+ (dotimes (,i ,min ,result)
+ (do* ((src ,seq-list (cdr src))
+ (seq (car src) (car src))
+ (dest ,var (cdr dest)))
+ ((null src))
+ (rplaca dest (if (consp seq)
+ (progn
+ (rplaca src (cdr seq))
+ (car seq))
+ (aref seq ,i))))
+ ,@body))))
+
+(defun map-into (result-sequence function &rest sequences)
+ "Modify RESULT-SEQUENCE, applying FUNCTION to the elements of SEQUENCES."
+ (etypecase result-sequence
+ (null nil)
+ (cons (let ((x result-sequence))
+ (do-sequences (args sequences result-sequence)
+ (when (endp x) (return result-sequence))
+ (rplaca x (apply function args))
+ (setq x (cdr x)))))
+ (vector (let ((i 0)
+ (length (array-dimension result-sequence 0)))
+ (do-sequences (args sequences)
+ (when (= i length) (return))
+ (setf (aref result-sequence i) (apply function args))
+ (setq i (1+ i)))
+ (when (array-has-fill-pointer-p result-sequence)
+ (setf (fill-pointer result-sequence) i))
+ result-sequence))))
+
+(defun map (result-type function sequence &rest more-sequences)
+ "Apply FUNCTION to the successive elements of SEQUENCE and MORE-SEQUENCES."
+ (if (null result-type)
+ (do-sequences (args (cons sequence more-sequences) nil)
+ (apply function args))
+ (let* ((sequences (cons sequence more-sequences))
+ (seq (make-sequence result-type
+ (reduce #'min sequences :key #'length))))
+ (apply #'map-into seq function sequences))))
+
+
+(defun every (predicate sequence &rest more-sequences)
+ "Return true if and only if every invocation of PREDICATE on SEQUENCE returns true."
+ (do-sequences (args (cons sequence more-sequences) t)
+ (unless (apply predicate args)
+ (return nil))))
+
+(defun some (predicate sequence &rest more-sequences)
+ "Return true if and only if some invocation of PREDICATE on SEQUENCE returns true."
+ (do-sequences (args (cons sequence more-sequences) nil)
+ (when (apply predicate args)
+ (return t))))
+
+(defun notevery (predicate sequence &rest more-sequences)
+ "Return true if and only if some invocation of PREDICATE on SEQUENCE returns false."
+ (not (apply #'every predicate sequence more-sequences)))
+
+(defun notany (predicate sequence &rest more-sequences)
+ "Return true if and only if every invocation of PREDICATE on SEQUENCE returns false."
+ (not (apply #'some predicate sequence more-sequences)))