;;; -*- Log: code.log; Package: Lisp -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the Spice Lisp project at ;;; Carnegie-Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of Spice Lisp, please contact ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; ;;; Functions to implement generic sequences for Spice Lisp. ;;; Written by Skef Wholey. ;;; Fixed up by Jim Muller on Friday the 13th, January, 1984. ;;; Gone over again by Bill Chiles. Next? ;;; ;;; Be careful when modifying code. A lot of the structure of the code is ;;; affected by the fact that compiler transforms use the lower level support ;;; functions. If transforms are written for some sequence operation, note ;;; how the end argument is handled in other operations with transforms. (in-package 'lisp) (export '(elt subseq copy-seq coerce length reverse nreverse make-sequence concatenate map some every notany notevery reduce fill replace remove remove-if remove-if-not delete delete-if delete-if-not remove-duplicates delete-duplicates substitute substitute-if substitute-if-not nsubstitute nsubstitute-if nsubstitute-if-not find find-if find-if-not position position-if position-if-not count count-if count-if-not mismatch search identity)) ; Yep, thet's whar it is. ;;; Spice-Lisp specific stuff and utilities: (eval-when (compile) ;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence. (defmacro seq-dispatch (sequence list-form array-form) `(if (listp ,sequence) ,list-form ,array-form)) (defmacro elt-slice (sequences n) "Returns a list of the Nth element of each of the sequences. Used by MAP and friends." `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences)) (defmacro make-sequence-like (sequence length) "Returns a sequence of the same type as SEQUENCE and the given LENGTH." `(make-sequence-of-type (type-of ,sequence) ,length)) (defmacro type-specifier (type) "Returns the broad class of which TYPE is a specific subclass." `(if (atom ,type) ,type (car ,type))) ) ; eval-when ;;; APPLY-KEY saves us a function call sometimes. ;;; This is not in and (eval-when (compile eval) ... ;;; because this is used in Sort.Lisp (defmacro apply-key (key element) `(if ,key (funcall ,key ,element) ,element)) (defun identity (thing) "Returns what was passed to it." thing) (defun make-sequence-of-type (type length) "Returns a sequence of the given TYPE and LENGTH." (declare (fixnum length)) (case (type-specifier type) (list (make-list length)) ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) ((string simple-string) (make-string length)) (simple-vector (make-array length)) ((array simple-array vector) (if (listp type) (make-array length :element-type (cadr type)) (make-array length))) ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) (t (error "~S is a bad type specifier for sequence functions." type)))) (defun elt (sequence index) "Returns the element of SEQUENCE specified by INDEX." (if (listp sequence) (if (< index 0) (error "~S: index too small." index) (do ((count index (1- count))) ((= count 0) (car sequence)) (declare (fixnum count)) (if (atom sequence) (error "~S: index too large." index) (setq sequence (cdr sequence))))) (aref sequence index))) (defun %setelt (sequence index newval) "Store NEWVAL as the component of SEQUENCE specified by INDEX." (if (listp sequence) (if (< index 0) (error "~S: index too small." index) (do ((count index (1- count)) (seq sequence)) ((= count 0) (rplaca seq newval) sequence) (declare (fixnum count)) (if (atom (cdr seq)) (error "~S: index too large." index) (setq seq (cdr seq))))) (setf (aref sequence index) newval))) (defun length (sequence) "Returns an integer that is the length of SEQUENCE." (%primitive length sequence)) (defun list-length* (sequence) (do ((count 0 (1+ count))) ((atom sequence) count) (declare (fixnum count)) (setq sequence (cdr sequence)))) (defun make-sequence (type length &key (initial-element NIL iep)) "Returns a sequence of the given Type and Length, with elements initialized to :Initial-Element." (declare (fixnum length)) (let ((type (type-expand type))) (cond ((subtypep type 'list) (make-list length :initial-element initial-element)) ((subtypep type 'string) (if iep (make-string length :initial-element initial-element) (make-string length))) ((subtypep type 'simple-vector) (make-array length :initial-element initial-element)) ((subtypep type 'bit-vector) (if iep (make-array length :element-type '(mod 2) :initial-element initial-element) (make-array length :element-type '(mod 2)))) ((subtypep type 'vector) (if (listp type) (if iep (make-array length :element-type (cadr type) :initial-element initial-element) (make-array length :element-type (cadr type) :initial-element (if (subtypep (cadr type) 'number) 0 NIL))) (make-array length :initial-element initial-element))) (t (error "~S is a bad type specifier for sequences." type))))) ;;; Subseq: ;;; ;;; The support routines for SUBSEQ are used by compiler transforms, so we ;;; worry about dealing with end being supplied as or defaulting to nil ;;; at this level. (defun vector-subseq* (sequence start &optional end) (declare (vector sequence) (fixnum start)) (when (null end) (setf end (length sequence))) (do ((old-index start (1+ old-index)) (new-index 0 (1+ new-index)) (copy (make-sequence-like sequence (- end start)))) ((= old-index end) copy) (declare (fixnum old-index new-index)) (setf (aref copy new-index) (aref sequence old-index)))) (defun list-subseq* (sequence start &optional end) (declare (list sequence) (fixnum start)) (if (and end (>= start (the fixnum end))) () (let* ((groveled (nthcdr start sequence)) (result (list (car groveled)))) (if groveled (do ((list (cdr groveled) (cdr list)) (splice result (cdr (rplacd splice (list (car list))))) (index (1+ start) (1+ index))) ((or (atom list) (and end (= index (the fixnum end)))) result) (declare (fixnum index))) ())))) ;;; SUBSEQ cannot default end to the length of sequence since it is not ;;; an error to supply nil for its value. We must test for end being nil ;;; in the body of the function, and this is actually done in the support ;;; routines for other reasons (see above). (defun subseq (sequence start &optional end) "Returns a copy of a subsequence of SEQUENCE starting with element number START and continuing to the end of SEQUENCE or the optional END." (seq-dispatch sequence (list-subseq* sequence start end) (vector-subseq* sequence start end))) ;;; Copy-seq: (eval-when (compile eval) (defmacro vector-copy-seq (sequence type) `(let ((length (length (the vector ,sequence)))) (declare (fixnum length)) (do ((index 0 (1+ index)) (copy (make-sequence-of-type ,type length))) ((= index length) copy) (declare (fixnum index)) (setf (aref copy index) (aref ,sequence index))))) (defmacro list-copy-seq (list) `(if (atom ,list) '() (let ((result (cons (car ,list) '()) )) (do ((x (cdr ,list) (cdr x)) (splice result (cdr (rplacd splice (cons (car x) '() ))) )) ((atom x) (unless (null x) (rplacd splice x)) result))))) ) (defun copy-seq (sequence) "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." (seq-dispatch sequence (list-copy-seq* sequence) (vector-copy-seq* sequence))) ;;; Internal Frobs: (defun list-copy-seq* (sequence) (list-copy-seq sequence)) (defun vector-copy-seq* (sequence) (vector-copy-seq sequence (type-of sequence))) ;;; Fill: (eval-when (compile eval) (defmacro vector-fill (sequence item start end) `(do ((index ,start (1+ index))) ((= index (the fixnum ,end)) ,sequence) (declare (fixnum index)) (setf (aref ,sequence index) ,item))) (defmacro list-fill (sequence item start end) `(do ((current (nthcdr ,start ,sequence) (cdr current)) (index ,start (1+ index))) ((or (atom current) (and end (= index (the fixnum ,end)))) sequence) (declare (fixnum index)) (rplaca current ,item))) ) ;;; The support routines for FILL are used by compiler transforms, so we ;;; worry about dealing with end being supplied as or defaulting to nil ;;; at this level. (defun list-fill* (sequence item start end) (declare (list sequence)) (list-fill sequence item start end)) (defun vector-fill* (sequence item start end) (declare (vector sequence)) (when (null end) (setq end (length sequence))) (vector-fill sequence item start end)) ;;; FILL cannot default end to the length of sequence since it is not ;;; an error to supply nil for its value. We must test for end being nil ;;; in the body of the function, and this is actually done in the support ;;; routines for other reasons (see above). (defun fill (sequence item &key (start 0) end) "Replace the specified elements of SEQUENCE with ITEM." (seq-dispatch sequence (list-fill* sequence item start end) (vector-fill* sequence item start end))) ;;; Replace: (eval-when (compile eval) ;;; If we are copying around in the same vector, be careful not to copy the ;;; same elements over repeatedly. We do this by copying backwards. (defmacro mumble-replace-from-mumble () `(if (and (eq target-sequence source-sequence) (> target-start source-start)) (let ((nelts (min (- target-end target-start) (- source-end source-start)))) (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1) (1- target-index)) (source-index (+ (the fixnum source-start) (the fixnum nelts) -1) (1- source-index))) ((= target-index (the fixnum (1- target-start))) target-sequence) (declare (fixnum target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index)))) (do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index))) ((or (= target-index (the fixnum target-end)) (= source-index (the fixnum source-end))) target-sequence) (declare (fixnum target-index source-index)) (setf (aref target-sequence target-index) (aref source-sequence source-index))))) (defmacro list-replace-from-list () `(if (and (eq target-sequence source-sequence) (> target-start source-start)) (let ((new-elts (subseq source-sequence source-start (+ (the fixnum source-start) (the fixnum (min (- (the fixnum target-end) (the fixnum target-start)) (- (the fixnum source-end) (the fixnum source-start)))))))) (do ((n new-elts (cdr n)) (o (nthcdr target-start target-sequence) (cdr o))) ((null n) target-sequence) (rplaca o (car n)))) (do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index)) (target-sequence-ref (nthcdr target-start target-sequence) (cdr target-sequence-ref)) (source-sequence-ref (nthcdr source-start source-sequence) (cdr source-sequence-ref))) ((or (= target-index (the fixnum target-end)) (= source-index (the fixnum source-end)) (null target-sequence-ref) (null source-sequence-ref)) target-sequence) (declare (fixnum target-index source-index)) (rplaca target-sequence-ref (car source-sequence-ref))))) (defmacro list-replace-from-mumble () `(do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index)) (target-sequence-ref (nthcdr target-start target-sequence) (cdr target-sequence-ref))) ((or (= target-index (the fixnum target-end)) (= source-index (the fixnum source-end)) (null target-sequence-ref)) target-sequence) (declare (fixnum source-index target-index)) (rplaca target-sequence-ref (aref source-sequence source-index)))) (defmacro mumble-replace-from-list () `(do ((target-index target-start (1+ target-index)) (source-index source-start (1+ source-index)) (source-sequence (nthcdr source-start source-sequence) (cdr source-sequence))) ((or (= target-index (the fixnum target-end)) (= source-index (the fixnum source-end)) (null source-sequence)) target-sequence) (declare (fixnum target-index source-index)) (setf (aref target-sequence target-index) (car source-sequence)))) ) ; eval-when ;;; The support routines for REPLACE are used by compiler transforms, so we ;;; worry about dealing with end being supplied as or defaulting to nil ;;; at this level. (defun list-replace-from-list* (target-sequence source-sequence target-start target-end source-start source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (list-replace-from-list)) (defun list-replace-from-vector* (target-sequence source-sequence target-start target-end source-start source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (list-replace-from-mumble)) (defun vector-replace-from-list* (target-sequence source-sequence target-start target-end source-start source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-list)) (defun vector-replace-from-vector* (target-sequence source-sequence target-start target-end source-start source-end) (when (null target-end) (setq target-end (length target-sequence))) (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-mumble)) ;;; REPLACE cannot default end arguments to the length of sequence since it ;;; is not an error to supply nil for their values. We must test for ends ;;; being nil in the body of the function. (defun replace (target-sequence source-sequence &key ((:start1 target-start) 0) ((:end1 target-end)) ((:start2 source-start) 0) ((:end2 source-end))) "The target sequence is destructively modified by copying successive elements into it from the source sequence." (unless target-end (setq target-end (length target-sequence))) (unless source-end (setq source-end (length source-sequence))) (seq-dispatch target-sequence (seq-dispatch source-sequence (list-replace-from-list) (list-replace-from-mumble)) (seq-dispatch source-sequence (mumble-replace-from-list) (mumble-replace-from-mumble)))) ;;; Reverse: (eval-when (compile eval) (defmacro vector-reverse (sequence type) `(let ((length (length ,sequence))) (declare (fixnum length)) (do ((forward-index 0 (1+ forward-index)) (backward-index (1- length) (1- backward-index)) (new-sequence (make-sequence-of-type ,type length))) ((= forward-index length) new-sequence) (declare (fixnum forward-index backward-index)) (setf (aref new-sequence forward-index) (aref ,sequence backward-index))))) (defmacro list-reverse-macro (sequence) `(do ((new-list ())) ((atom ,sequence) new-list) (push (pop ,sequence) new-list))) ) (defun reverse (sequence) "Returns a new sequence containing the same elements but in reverse order." (seq-dispatch sequence (list-reverse* sequence) (vector-reverse* sequence))) ;;; Internal Frobs: (defun list-reverse* (sequence) (list-reverse-macro sequence)) (defun vector-reverse* (sequence) (vector-reverse sequence (type-of sequence))) ;;; Nreverse: (eval-when (compile eval) (defmacro vector-nreverse (sequence) `(let ((length (length (the vector ,sequence)))) (declare (fixnum length)) (do ((left-index 0 (1+ left-index)) (right-index (1- length) (1- right-index)) (half-length (truncate length 2))) ((= left-index half-length) ,sequence) (declare (fixnum left-index right-index half-length)) (rotatef (aref ,sequence left-index) (aref ,sequence right-index))))) (defmacro list-nreverse-macro (list) `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st))) (2nd ,list 1st) (3rd '() 2nd)) ((atom 2nd) 3rd) (rplacd 2nd 3rd))) ) (defun list-nreverse* (sequence) (list-nreverse-macro sequence)) (defun vector-nreverse* (sequence) (vector-nreverse sequence)) (defun nreverse (sequence) "Returns a sequence of the same elements in reverse order; the argument is destroyed." (seq-dispatch sequence (list-nreverse* sequence) (vector-nreverse* sequence))) ;;; Concatenate: (eval-when (compile eval) (defmacro concatenate-to-list (sequences) `(let ((result (list nil))) (do ((sequences ,sequences (cdr sequences)) (splice result)) ((null sequences) (cdr result)) (let ((sequence (car sequences))) (seq-dispatch sequence (do ((sequence sequence (cdr sequence))) ((atom sequence)) (setq splice (cdr (rplacd splice (list (car sequence)))))) (do ((index 0 (1+ index)) (length (length sequence))) ((= index length)) (declare (fixnum index length)) (setq splice (cdr (rplacd splice (list (aref sequence index))))))))))) (defmacro concatenate-to-mumble (output-type-spec sequences) `(do ((seqs ,sequences (cdr seqs)) (total-length 0) (lengths ())) ((null seqs) (do ((sequences ,sequences (cdr sequences)) (lengths lengths (cdr lengths)) (index 0) (result (make-sequence-of-type ,output-type-spec total-length))) ((= index total-length) result) (declare (fixnum index)) (let ((sequence (car sequences))) (seq-dispatch sequence (do ((sequence sequence (cdr sequence))) ((atom sequence)) (setf (aref result index) (car sequence)) (setq index (1+ index))) (do ((jndex 0 (1+ jndex)) (this-length (car lengths))) ((= jndex this-length)) (declare (fixnum jndex this-length)) (setf (aref result index) (aref sequence jndex)) (setq index (1+ index))))))) (let ((length (length (car seqs)))) (declare (fixnum length)) (setq lengths (nconc lengths (list length))) (setq total-length (+ total-length length))))) ) (defun concatenate (output-type-spec &rest sequences) "Returns a new sequence of all the argument sequences concatenated together which shares no structure with the original argument sequences of the specified OUTPUT-TYPE-SPEC." (case (type-specifier output-type-spec) (list (apply #'concat-to-list* sequences)) ((simple-vector simple-string vector string array simple-array bit-vector simple-bit-vector) (apply #'concat-to-simple* output-type-spec sequences)) (t (error "~S: invalid output type specification." output-type-spec)))) ;;; Internal Frobs: (defun concat-to-list* (&rest sequences) (concatenate-to-list sequences)) (defun concat-to-simple* (type &rest sequences) (concatenate-to-mumble type sequences)) ;;; Map: (eval-when (compile eval) (defmacro map-to-list (function sequences) `(do ((seqs more-sequences (cdr seqs)) (min-length (length first-sequence))) ((null seqs) (let ((result (list nil))) (do ((index 0 (1+ index)) (splice result)) ((= index min-length) (cdr result)) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (apply ,function (elt-slice ,sequences index))))))))) (declare (fixnum min-length)) (let ((length (length (car seqs)))) (declare (fixnum length)) (if (< length min-length) (setq min-length length))))) (defmacro map-to-simple (output-type-spec function sequences) `(do ((seqs more-sequences (cdr seqs)) (min-length (length first-sequence))) ((null seqs) (do ((index 0 (1+ index)) (result (make-sequence-of-type ,output-type-spec min-length))) ((= index min-length) result) (declare (fixnum index)) (setf (aref result index) (apply ,function (elt-slice ,sequences index))))) (declare (fixnum min-length)) (let ((length (length (car seqs)))) (declare (fixnum length)) (if (< length min-length) (setq min-length length))))) (defmacro map-for-effect (function sequences) `(do ((seqs more-sequences (cdr seqs)) (min-length (length first-sequence))) ((null seqs) (do ((index 0 (1+ index))) ((= index min-length) nil) (apply ,function (elt-slice ,sequences index)))) (declare (fixnum min-length)) (let ((length (length (car seqs)))) (declare (fixnum length)) (if (< length min-length) (setq min-length length))))) ) (defun map (output-type-spec function first-sequence &rest more-sequences) "FUNCTION must take as many arguments as there are sequences provided. The result is a sequence such that element i is the result of applying FUNCTION to element i of each of the argument sequences." (let ((sequences (cons first-sequence more-sequences))) (case (type-specifier output-type-spec) ((nil) (map-for-effect function sequences)) (list (map-to-list function sequences)) ((simple-vector simple-string vector string array simple-array bit-vector simple-bit-vector) (map-to-simple output-type-spec function sequences)) (t (error "~S: invalid output type specifier." output-type-spec))))) ;;; Quantifiers: (eval-when (compile eval) (defmacro defquantifier (name doc-string every-result abort-sense abort-value) `(defun ,name (predicate first-sequence &rest more-sequences) ,doc-string (do ((seqs more-sequences (cdr seqs)) (length (length first-sequence)) (sequences (cons first-sequence more-sequences))) ((null seqs) (do ((index 0 (1+ index))) ((= index length) ,every-result) (declare (fixnum index)) (let ((result (apply predicate (elt-slice sequences index)))) (if ,(if abort-sense 'result '(not result)) (return ,abort-value))))) (declare (fixnum length)) (let ((this (length (car seqs)))) (declare (fixnum this)) (if (< this length) (setq length this)))))) ) ; eval-when (defquantifier some "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. SOME returns the first non-() value encountered, or () if the end of a sequence is reached." nil t result) (defquantifier every "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. EVERY returns () as soon as any invocation of PREDICATE returns (), or T if every invocation is non-()." t nil nil) (defquantifier notany "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTANY returns () as soon as any invocation of PREDICATE returns a non-() value, or T if the end of a sequence is reached." t t nil) (defquantifier notevery "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTEVERY returns T as soon as any invocation of PREDICATE returns (), or () if every invocation is non-()." nil nil t) ;;; Reduce: (eval-when (compile eval) (defmacro mumble-reduce (function sequence start end initial-value ref) `(do ((index ,start (1+ index)) (value ,initial-value)) ((= index (the fixnum ,end)) value) (declare (fixnum index)) (setq value (funcall ,function value (,ref ,sequence index))))) (defmacro mumble-reduce-from-end (function sequence start end initial-value ref) `(do ((index (1- ,end) (1- index)) (value ,initial-value) (terminus (1- ,start))) ((= index terminus) value) (declare (fixnum index terminus)) (setq value (funcall ,function (,ref ,sequence index) value)))) (defmacro list-reduce (function sequence start end initial-value ivp) `(let ((sequence (nthcdr ,start ,sequence))) (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) (1+ count)) (sequence (if ,ivp sequence (cdr sequence)) (cdr sequence)) (value (if ,ivp ,initial-value (car sequence)) (funcall ,function value (car sequence)))) ((= count (the fixnum ,end)) value) (declare (fixnum count))))) (defmacro list-reduce-from-end (function sequence start end initial-value ivp) `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) (the fixnum ,end)) (reverse ,sequence)))) (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) (1+ count)) (sequence (if ,ivp sequence (cdr sequence)) (cdr sequence)) (value (if ,ivp ,initial-value (car sequence)) (funcall ,function (car sequence) value))) ((= count (the fixnum ,end)) value) (declare (fixnum count))))) ) (defun reduce (function sequence &key from-end (start 0) end (initial-value nil ivp)) "The specified Sequence is ``reduced'' using the given Function. See manual for details." (declare (fixnum start)) (when (null end) (setf end (length sequence))) (cond ((= (the fixnum end) start) (if ivp initial-value (funcall function))) ((listp sequence) (if from-end (list-reduce-from-end function sequence start end initial-value ivp) (list-reduce function sequence start end initial-value ivp))) (from-end (when (not ivp) (setq end (1- (the fixnum end))) (setq initial-value (aref sequence end))) (mumble-reduce-from-end function sequence start end initial-value aref)) (t (when (not ivp) (setq initial-value (aref sequence start)) (setq start (1+ start))) (mumble-reduce function sequence start end initial-value aref)))) ;;; Coerce: (defun coerce (object output-type-spec) "Coerces the Object to an object of type Output-Type-Spec." (cond ((typep object output-type-spec) object) ((eq output-type-spec 'character) (character object)) ((eq output-type-spec 'function) (eval `#',object)) ((numberp object) (case output-type-spec (short-float (%primitive float-short object)) ((single-float float) (%primitive float-single object)) ((double-float long-float) (%primitive float-long object)) (complex (complex object)) (t (error "~S can't be converted to type ~S." object output-type-spec)))) (t (typecase object (list (case (type-specifier output-type-spec) ((simple-string string) (list-to-string* object)) ((simple-bit-vector bit-vector) (list-to-bit-vector* object)) ((simple-vector vector array simple-array) (list-to-vector* object output-type-spec)) (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (simple-string (case (type-specifier output-type-spec) (list (vector-to-list* object)) ;; Can't coerce a string to a bit-vector! ((simple-vector vector array simple-array) (vector-to-vector* object output-type-spec)) (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (simple-bit-vector (case (type-specifier output-type-spec) (list (vector-to-list* object)) ;; Can't coerce a bit-vector to a string! ((simple-vector vector array simple-array) (vector-to-vector* object output-type-spec)) (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (simple-vector (case (type-specifier output-type-spec) (list (vector-to-list* object)) ((simple-string string) (vector-to-string* object)) ((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) ((vector array simple-array) (vector-to-vector* object output-type-spec)) (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (string (case (type-specifier output-type-spec) (list (vector-to-list* object)) (simple-string (string-to-simple-string* object)) ;; Can't coerce a string to a bit-vector! ((simple-vector vector simple-array array) (vector-to-vector* object output-type-spec)) (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (bit-vector (case (type-specifier output-type-spec) (list (vector-to-list* object)) ;; Can't coerce a bit-vector to a string! (simple-bit-vector (bit-vector-to-simple-bit-vector* object)) ((simple-vector vector array simple-array) (vector-to-vector* object output-type-spec)) (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (vector (case (type-specifier output-type-spec) (list (vector-to-list* object)) ((simple-string string) (vector-to-string* object)) ((simple-bit-vector bit-vector) (vector-to-bit-vector* object)) ((simple-vector vector array simple-array) (vector-to-vector* object output-type-spec)) (t (error "Can't coerce ~S to type ~S." object output-type-spec)))) (t (error "~S is an inappropriate type of object for coerce." object)))))) ;;; Internal Frobs: (macrolet ((frob (name result access src-type &optional typep) `(defun ,name (object ,@(if typep '(type) ())) (do* ((index 0 (1+ index)) (length (,(case src-type (:list 'list-length*) (:vector 'length)) object)) (result ,result)) ((= index length) result) (declare (fixnum length index)) (setf (,access result index) ,(case src-type (:list '(pop object)) (:vector '(aref object index)))))))) (frob list-to-string* (make-string length) schar :list) (frob list-to-bit-vector* (make-array length :element-type '(mod 2)) sbit :list) (frob list-to-vector* (make-sequence-of-type type length) aref :list t) (frob vector-to-vector* (make-sequence-of-type type length) aref :vector t) (frob vector-to-string* (make-string length) schar :vector) (frob vector-to-bit-vector* (make-array length :element-type '(mod 2)) sbit :vector)) (defun vector-to-list* (object) (let ((result (list nil)) (length (length object))) (declare (fixnum length)) (do ((index 0 (1+ index)) (splice result (cdr splice))) ((= index length) (cdr result)) (declare (fixnum index)) (rplacd splice (list (aref object index)))))) (defun string-to-simple-string* (object) (if (simple-string-p object) object (with-array-data ((data object) (start) (end (%primitive header-ref object %array-fill-pointer-slot))) (declare (simple-string data)) (subseq data start end)))) (defun bit-vector-to-simple-bit-vector* (object) (if (simple-bit-vector-p object) object (with-array-data ((data object) (start) (end (%primitive header-ref object %array-fill-pointer-slot))) (declare (simple-bit-vector data)) (subseq data start end)))) ;;; Delete: (eval-when (compile eval) (defmacro mumble-delete (pred) `(do ((index start (1+ index)) (jndex start) (number-zapped 0)) ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) (do ((index index (1+ index)) ; copy the rest of the vector (jndex jndex (1+ jndex))) ((= index (the fixnum length)) (shrink-vector sequence jndex)) (declare (fixnum index jndex)) (setf (aref sequence jndex) (aref sequence index)))) (declare (fixnum index jndex number-zapped)) (setf (aref sequence jndex) (aref sequence index)) (if ,pred (setq number-zapped (1+ number-zapped)) (setq jndex (1+ jndex))))) (defmacro mumble-delete-from-end (pred) `(do ((index (1- (the fixnum end)) (1- index)) ; find the losers (number-zapped 0) (losers ()) this-element (terminus (1- start))) ((or (= index terminus) (= number-zapped (the fixnum count))) (do ((losers losers) ; delete the losers (index start (1+ index)) (jndex start)) ((or (null losers) (= index (the fixnum end))) (do ((index index (1+ index)) ; copy the rest of the vector (jndex jndex (1+ jndex))) ((= index (the fixnum length)) (shrink-vector sequence jndex)) (declare (fixnum index jndex)) (setf (aref sequence jndex) (aref sequence index)))) (declare (fixnum index jndex)) (setf (aref sequence jndex) (aref sequence index)) (if (= index (the fixnum (car losers))) (pop losers) (setq jndex (1+ jndex))))) (declare (fixnum index number-zapped terminus)) (setq this-element (aref sequence index)) (when ,pred (setq number-zapped (1+ number-zapped)) (push index losers)))) (defmacro normal-mumble-delete () `(mumble-delete (if test-not (not (funcall test-not item (apply-key key (aref sequence index)))) (funcall test item (apply-key key (aref sequence index)))))) (defmacro normal-mumble-delete-from-end () `(mumble-delete-from-end (if test-not (not (funcall test-not item (apply-key key this-element))) (funcall test item (apply-key key this-element))))) (defmacro list-delete (pred) `(let ((handle (cons nil sequence))) (do ((current (nthcdr start sequence) (cdr current)) (previous (nthcdr start handle)) (index start (1+ index)) (number-zapped 0)) ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) (cdr handle)) (declare (fixnum index number-zapped)) (cond (,pred (rplacd previous (cdr current)) (setq number-zapped (1+ number-zapped))) (t (setq previous (cdr previous))))))) (defmacro list-delete-from-end (pred) `(let* ((reverse (nreverse (the list sequence))) (handle (cons nil reverse))) (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse) (cdr current)) (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle)) (index start (1+ index)) (number-zapped 0)) ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) (nreverse (cdr handle))) (declare (fixnum index number-zapped)) (cond (,pred (rplacd previous (cdr current)) (setq number-zapped (1+ number-zapped))) (t (setq previous (cdr previous))))))) (defmacro normal-list-delete () '(list-delete (if test-not (not (funcall test-not item (apply-key key (car current)))) (funcall test item (apply-key key (car current)))))) (defmacro normal-list-delete-from-end () '(list-delete-from-end (if test-not (not (funcall test-not item (apply-key key (car current)))) (funcall test item (apply-key key (car current)))))) ) (defun delete (item sequence &key from-end (test #'eql) test-not (start 0) end (count most-positive-fixnum) key) "Returns a sequence formed by destructively removing the specified Item from the given Sequence." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence))) (declare (fixnum length)) (seq-dispatch sequence (if from-end (normal-list-delete-from-end) (normal-list-delete)) (if from-end (normal-mumble-delete-from-end) (normal-mumble-delete))))) (eval-when (compile eval) (defmacro if-mumble-delete () `(mumble-delete (funcall predicate (apply-key key (aref sequence index))))) (defmacro if-mumble-delete-from-end () `(mumble-delete-from-end (funcall predicate (apply-key key this-element)))) (defmacro if-list-delete () '(list-delete (funcall predicate (apply-key key (car current))))) (defmacro if-list-delete-from-end () '(list-delete-from-end (funcall predicate (apply-key key (car current))))) ) (defun delete-if (predicate sequence &key from-end (start 0) key end (count most-positive-fixnum)) "Returns a sequence formed by destructively removing the elements satisfying the specified Predicate from the given Sequence." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence))) (declare (fixnum length)) (seq-dispatch sequence (if from-end (if-list-delete-from-end) (if-list-delete)) (if from-end (if-mumble-delete-from-end) (if-mumble-delete))))) (eval-when (compile eval) (defmacro if-not-mumble-delete () `(mumble-delete (not (funcall predicate (apply-key key (aref sequence index)))))) (defmacro if-not-mumble-delete-from-end () `(mumble-delete-from-end (not (funcall predicate (apply-key key this-element))))) (defmacro if-not-list-delete () '(list-delete (not (funcall predicate (apply-key key (car current)))))) (defmacro if-not-list-delete-from-end () '(list-delete-from-end (not (funcall predicate (apply-key key (car current)))))) ) (defun delete-if-not (predicate sequence &key from-end (start 0) end key (count most-positive-fixnum)) "Returns a sequence formed by destructively removing the elements not satisfying the specified Predicate from the given Sequence." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence))) (declare (fixnum length)) (seq-dispatch sequence (if from-end (if-not-list-delete-from-end) (if-not-list-delete)) (if from-end (if-not-mumble-delete-from-end) (if-not-mumble-delete))))) ;;; Remove: (eval-when (compile eval) ;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that ;;; satisfies the predicate. (defmacro mumble-remove-macro (bump left begin finish right pred) `(do ((index ,begin (,bump index)) (result (do ((index ,left (,bump index)) (result (make-sequence-like sequence length))) ((= index (the fixnum ,begin)) result) (declare (fixnum index)) (setf (aref result index) (aref sequence index)))) (new-index ,begin) (number-zapped 0) (this-element)) ((or (= index (the fixnum ,finish)) (= number-zapped (the fixnum count))) (do ((index index (,bump index)) (new-index new-index (,bump new-index))) ((= index (the fixnum ,right)) (shrink-vector result new-index)) (declare (fixnum index new-index)) (setf (aref result new-index) (aref sequence index)))) (declare (fixnum index new-index number-zapped)) (setq this-element (aref sequence index)) (cond (,pred (setq number-zapped (1+ number-zapped))) (t (setf (aref result new-index) this-element) (setq new-index (,bump new-index)))))) (defmacro mumble-remove (pred) `(mumble-remove-macro 1+ 0 start end length ,pred)) (defmacro mumble-remove-from-end (pred) `(let ((sequence (copy-seq sequence))) (mumble-delete-from-end ,pred))) (defmacro normal-mumble-remove () `(mumble-remove (if test-not (not (funcall test-not item (apply-key key this-element))) (funcall test item (apply-key key this-element))))) (defmacro normal-mumble-remove-from-end () `(mumble-remove-from-end (if test-not (not (funcall test-not item (apply-key key this-element))) (funcall test item (apply-key key this-element))))) (defmacro if-mumble-remove () `(mumble-remove (funcall predicate (apply-key key this-element)))) (defmacro if-mumble-remove-from-end () `(mumble-remove-from-end (funcall predicate (apply-key key this-element)))) (defmacro if-not-mumble-remove () `(mumble-remove (not (funcall predicate (apply-key key this-element))))) (defmacro if-not-mumble-remove-from-end () `(mumble-remove-from-end (not (funcall predicate (apply-key key this-element))))) ;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies ;;; the predicate. (defmacro list-remove-macro (pred reverse?) `(let* (,@(if reverse? '((sequence (reverse (the list sequence))))) (splice (list nil)) (results (do ((index 0 (1+ index)) (before-start splice)) ((= index (the fixnum start)) before-start) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (pop sequence)))))))) (do ((index start (1+ index)) (this-element) (number-zapped 0)) ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) (do ((index index (1+ index))) ((null sequence) ,(if reverse? '(nreverse (the list (cdr results))) '(cdr results))) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (pop sequence))))))) (declare (fixnum index number-zapped)) (setq this-element (pop sequence)) (if ,pred (setq number-zapped (1+ number-zapped)) (setq splice (cdr (rplacd splice (list this-element)))))))) (defmacro list-remove (pred) `(list-remove-macro ,pred nil)) (defmacro list-remove-from-end (pred) `(list-remove-macro ,pred t)) (defmacro normal-list-remove () `(list-remove (if test-not (not (funcall test-not item (apply-key key this-element))) (funcall test item (apply-key key this-element))))) (defmacro normal-list-remove-from-end () `(list-remove-from-end (if test-not (not (funcall test-not item (apply-key key this-element))) (funcall test item (apply-key key this-element))))) (defmacro if-list-remove () `(list-remove (funcall predicate (apply-key key this-element)))) (defmacro if-list-remove-from-end () `(list-remove-from-end (funcall predicate (apply-key key this-element)))) (defmacro if-not-list-remove () `(list-remove (not (funcall predicate (apply-key key this-element))))) (defmacro if-not-list-remove-from-end () `(list-remove-from-end (not (funcall predicate (apply-key key this-element))))) ) (defun remove (item sequence &key from-end (test #'eql) test-not (start 0) end (count most-positive-fixnum) key) "Returns a copy of SEQUENCE with elements satisfying the test (default is EQL) with ITEM removed." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence))) (declare (fixnum length)) (seq-dispatch sequence (if from-end (normal-list-remove-from-end) (normal-list-remove)) (if from-end (normal-mumble-remove-from-end) (normal-mumble-remove))))) (defun remove-if (predicate sequence &key from-end (start 0) end (count most-positive-fixnum) key) "Returns a copy of sequence with elements such that predicate(element) is non-null are removed" (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence))) (declare (fixnum length)) (seq-dispatch sequence (if from-end (if-list-remove-from-end) (if-list-remove)) (if from-end (if-mumble-remove-from-end) (if-mumble-remove))))) (defun remove-if-not (predicate sequence &key from-end (start 0) end (count most-positive-fixnum) key) "Returns a copy of sequence with elements such that predicate(element) is null are removed" (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence))) (declare (fixnum length)) (seq-dispatch sequence (if from-end (if-not-list-remove-from-end) (if-not-list-remove)) (if from-end (if-not-mumble-remove-from-end) (if-not-mumble-remove))))) ;;; Remove-Duplicates: ;;; Remove duplicates from a list. If from-end, remove the later duplicates, ;;; not the earlier ones. Thus if we check from-end we don't copy an item ;;; if we look into the already copied structure (from after :start) and see ;;; the item. If we check from beginning we check into the rest of the ;;; original list up to the :end marker (this we have to do by running a ;;; do loop down the list that far and using our test. (defun list-remove-duplicates* (list test test-not start end key from-end) (declare (fixnum start)) (let* ((result (list ())) ; Put a marker on the beginning to splice with. (splice result) (current list)) (do ((index 0 (1+ index))) ((= index start)) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (car current))))) (setq current (cdr current))) (do ((index 0 (1+ index))) ((or (and end (= index (the fixnum end))) (atom current))) (declare (fixnum index)) (if (or (and from-end (not (member (apply-key key (car current)) (nthcdr start result) :test test :test-not test-not :key (if key key #'identity)))) (and (not from-end) (not (do ((it (apply-key key (car current))) (l (cdr current) (cdr l)) (i (1+ index) (1+ i))) ((or (atom l) (and end (= i (the fixnum end)))) ()) (declare (fixnum i)) (if (if test-not (not (funcall test-not (apply-key key (car l)) it)) (funcall test (apply-key key (car l)) it)) (return t)))))) (setq splice (cdr (rplacd splice (list (car current)))))) (setq current (cdr current))) (do () ((atom current)) (setq splice (cdr (rplacd splice (list (car current))))) (setq current (cdr current))) (cdr result))) (defun vector-remove-duplicates* (vector test test-not start end key from-end &optional (length (length vector))) (declare (vector vector) (fixnum start length)) (when (null end) (setf end (length vector))) (let ((result (make-sequence-like vector length)) (index 0) (jndex start)) (declare (fixnum index jndex)) (do () ((= index start)) (setf (aref result index) (aref vector index)) (setq index (1+ index))) (do ((elt)) ((= index end)) (setq elt (aref vector index)) (unless (or (and from-end (position (apply-key key elt) result :start start :end jndex :test test :test-not test-not :key key)) (and (not from-end) (position (apply-key key elt) vector :start (1+ index) :end end :test test :test-not test-not :key key))) (setf (aref result jndex) elt) (setq jndex (1+ jndex))) (setq index (1+ index))) (do () ((= index length)) (setf (aref result jndex) (aref vector index)) (setq index (1+ index)) (setq jndex (1+ jndex))) (shrink-vector result jndex))) (defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key) "The elements of Sequence are examined, and if any two match, one is discarded. The resulting sequence is returned." (declare (fixnum start)) (seq-dispatch sequence (if sequence (list-remove-duplicates* sequence test test-not start end key from-end)) (vector-remove-duplicates* sequence test test-not start end key from-end))) ;;; Delete-Duplicates: (defun list-delete-duplicates* (list test test-not key from-end start end) (declare (fixnum start)) (let ((handle (cons nil list))) (do ((current (nthcdr start list) (cdr current)) (previous (nthcdr start handle)) (index start (1+ index))) ((or (and end (= index (the fixnum end))) (null current)) (cdr handle)) (declare (fixnum index)) (if (do ((x (if from-end (nthcdr (1+ start) handle) (cdr current)) (cdr x)) (i (1+ index) (1+ i))) ((or (null x) (and (not from-end) end (= i (the fixnum end))) (eq x current)) nil) (declare (fixnum i)) (if (if test-not (not (funcall test-not (apply-key key (car current)) (apply-key key (car x)))) (funcall test (apply-key key (car current)) (apply-key key (car x)))) (return t))) (rplacd previous (cdr current)) (setq previous (cdr previous)))))) (defun vector-delete-duplicates* (vector test test-not key from-end start end &optional (length (length vector))) (declare (vector vector) (fixnum start length)) (when (null end) (setf end (length vector))) (do ((index start (1+ index)) (jndex start)) ((= index end) (do ((index index (1+ index)) ; copy the rest of the vector (jndex jndex (1+ jndex))) ((= index length) (shrink-vector vector jndex) vector) (setf (aref vector jndex) (aref vector index)))) (declare (fixnum index jndex)) (setf (aref vector jndex) (aref vector index)) (unless (position (apply-key key (aref vector index)) vector :key key :start (if from-end start (1+ index)) :test test :end (if from-end jndex end) :test-not test-not) (setq jndex (1+ jndex))))) (defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key) "The elements of Sequence are examined, and if any two match, one is discarded. The resulting sequence, which may be formed by destroying the given sequence, is returned." (seq-dispatch sequence (if sequence (list-delete-duplicates* sequence test test-not key from-end start end)) (vector-delete-duplicates* sequence test test-not key from-end start end))) (defun list-substitute* (pred new list start end count key test test-not old) (declare (fixnum start end count)) (let* ((result (list nil)) elt (splice result) (list list)) ; Get a local list for a stepper. (do ((index 0 (1+ index))) ((= index start)) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (car list))))) (setq list (cdr list))) (do ((index start (1+ index))) ((or (= index end) (null list) (= count 0))) (declare (fixnum index)) (setq elt (car list)) (setq splice (cdr (rplacd splice (list (cond ((case pred (normal (if test-not (not (funcall test-not (apply-key key elt) old)) (funcall test (apply-key key elt) old))) (if (funcall test (apply-key key elt))) (if-not (not (funcall test (apply-key key elt))))) (setq count (1- count)) new) (t elt)))))) (setq list (cdr list))) (do () ((null list)) (setq splice (cdr (rplacd splice (list (car list))))) (setq list (cdr list))) (cdr result))) ;;; Replace old with new in sequence moving from left to right by incrementer ;;; on each pass through the loop. Called by all three substitute functions. (defun vector-substitute* (pred new sequence incrementer left right length start end count key test test-not old) (declare (fixnum start count end incrementer right)) (let ((result (make-sequence-like sequence length)) (index left)) (declare (fixnum index)) (do () ((= index start)) (setf (aref result index) (aref sequence index)) (setq index (+ index incrementer))) (do ((elt)) ((or (= index end) (= count 0))) (setq elt (aref sequence index)) (setf (aref result index) (cond ((case pred (normal (if test-not (not (funcall test-not (apply-key key elt) old)) (funcall test (apply-key key elt) old))) (if (funcall test (apply-key key elt))) (if-not (not (funcall test (apply-key key elt))))) (setq count (1- count)) new) (t elt))) (setq index (+ index incrementer))) (do () ((= index right)) (setf (aref result index) (aref sequence index)) (setq index (+ index incrementer))) result)) (eval-when (compile eval) (defmacro subst-dispatch (pred) `(if (listp sequence) (if from-end (nreverse (list-substitute* ,pred new (reverse sequence) (- (the fixnum length) (the fixnum end)) (- (the fixnum length) (the fixnum start)) count key test test-not old)) (list-substitute* ,pred new sequence start end count key test test-not old)) (if from-end (vector-substitute* ,pred new sequence -1 (1- (the fixnum length)) -1 length (1- (the fixnum end)) (1- (the fixnum start)) count key test test-not old) (vector-substitute* ,pred new sequence 1 0 length length start end count key test test-not old)))) ) ;;; Substitute: (defun substitute (new old sequence &key from-end (test #'eql) test-not (start 0) (count most-positive-fixnum) end key) "Returns a sequence of the same kind as Sequence with the same elements except that all elements equal to Old are replaced with New. See manual for details." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence)) (old (apply-key key old))) (declare (fixnum length)) (subst-dispatch 'normal))) ;;; Substitute-If: (defun substitute-if (new test sequence &key from-end (start 0) end (count most-positive-fixnum) key) "Returns a sequence of the same kind as Sequence with the same elements except that all elements satisfying the Test are replaced with New. See manual for details." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence)) test-not old) (declare (fixnum length)) (subst-dispatch 'if))) ;;; Substitute-If-Not: (defun substitute-if-not (new test sequence &key from-end (start 0) end (count most-positive-fixnum) key) "Returns a sequence of the same kind as Sequence with the same elements except that all elements not satisfying the Test are replaced with New. See manual for details." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((length (length sequence)) test-not old) (declare (fixnum length)) (subst-dispatch 'if-not))) ;;; NSubstitute: (defun nsubstitute (new old sequence &key from-end (test #'eql) test-not end (count most-positive-fixnum) key (start 0)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements equal to Old are replaced with New. The Sequence may be destroyed. See manual for details." (declare (fixnum count start)) (when (null end) (setf end (length sequence))) (let ((incrementer 1)) (declare (fixnum incrementer)) (if from-end (psetq start (1- end) end (1- start) incrementer -1)) (if (listp sequence) (if from-end (nreverse (nlist-substitute* new old (nreverse (the list sequence)) test test-not start end count key)) (nlist-substitute* new old sequence test test-not start end count key)) (nvector-substitute* new old sequence incrementer test test-not start end count key)))) (defun nlist-substitute* (new old sequence test test-not start end count key) (declare (fixnum start count end)) (do ((list (nthcdr start sequence) (cdr list)) (index start (1+ index))) ((or (= index end) (null list) (= count 0)) sequence) (declare (fixnum index)) (when (if test-not (not (funcall test-not (apply-key key (car list)) old)) (funcall test (apply-key key (car list)) old)) (rplaca list new) (setq count (1- count))))) (defun nvector-substitute* (new old sequence incrementer test test-not start end count key) (declare (fixnum start incrementer count end)) (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (declare (fixnum index)) (when (if test-not (not (funcall test-not (apply-key key (aref sequence index)) old)) (funcall test (apply-key key (aref sequence index)) old)) (setf (aref sequence index) new) (setq count (1- count))))) ;;; NSubstitute-If: (defun nsubstitute-if (new test sequence &key from-end (start 0) end (count most-positive-fixnum) key) "Returns a sequence of the same kind as Sequence with the same elements except that all elements satisfying the Test are replaced with New. The Sequence may be destroyed. See manual for details." (declare (fixnum start count)) (when (null end) (setf end (length sequence))) (let ((incrementer 1)) (declare (fixnum incrementer)) (if from-end (psetq start (1- end) end (1- start) incrementer -1)) (if (listp sequence) (if from-end (nreverse (nlist-substitute-if* new test (nreverse (the list sequence)) start end count key)) (nlist-substitute-if* new test sequence start end count key)) (nvector-substitute-if* new test sequence incrementer start end count key)))) (defun nlist-substitute-if* (new test sequence start end count key) (declare (fixnum end)) (do ((list (nthcdr start sequence) (cdr list)) (index start (1+ index))) ((or (= index end) (null list) (= count 0)) sequence) (when (funcall test (apply-key key (car list))) (rplaca list new) (setq count (1- count))))) (defun nvector-substitute-if* (new test sequence incrementer start end count key) (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (when (funcall test (apply-key key (aref sequence index))) (setf (aref sequence index) new) (setq count (1- count))))) ;;; NSubstitute-If-Not: (defun nsubstitute-if-not (new test sequence &key from-end (start 0) end (count most-positive-fixnum) key) "Returns a sequence of the same kind as Sequence with the same elements except that all elements not satisfying the Test are replaced with New. The Sequence may be destroyed. See manual for details." (declare (fixnum start end count)) (when (null end) (setf end (length sequence))) (let ((incrementer 1)) (if from-end (psetq start (1- end) end (1- start) incrementer -1)) (if (listp sequence) (if from-end (nreverse (nlist-substitute-if-not* new test (nreverse (the list sequence)) start end count key)) (nlist-substitute-if-not* new test sequence start end count key)) (nvector-substitute-if-not* new test sequence incrementer start end count key)))) (defun nlist-substitute-if-not* (new test sequence start end count key) (declare (fixnum end)) (do ((list (nthcdr start sequence) (cdr list)) (index start (1+ index))) ((or (= index end) (null list) (= count 0)) sequence) (when (not (funcall test (apply-key key (car list)))) (rplaca list new) (setq count (1- count))))) (defun nvector-substitute-if-not* (new test sequence incrementer start end count key) (do ((index start (+ index incrementer))) ((or (= index end) (= count 0)) sequence) (when (not (funcall test (apply-key key (aref sequence index)))) (setf (aref sequence index) new) (setq count (1- count))))) ;;; Locater macros used by FIND and POSITION. (eval-when (compile eval) (defmacro vector-locater-macro (sequence body-form return-type) `(let ((incrementer (if from-end -1 1)) (start (if from-end (1- (the fixnum end)) start)) (end (if from-end (1- (the fixnum start)) end))) (declare (fixnum start end incrementer)) (do ((index start (+ index incrementer)) ,@(case return-type (:position nil) (:element '(current)))) ((= index end) ()) (declare (fixnum index)) ,@(case return-type (:position nil) (:element `((setf current (aref ,sequence index))))) ,body-form))) (defmacro locater-test-not (item sequence seq-type return-type) (let ((seq-ref (case return-type (:position (case seq-type (:vector `(aref ,sequence index)) (:list `(pop ,sequence)))) (:element 'current))) (return (case return-type (:position 'index) (:element 'current)))) `(if test-not (if (not (funcall test-not ,item (apply-key key ,seq-ref))) (return ,return)) (if (funcall test ,item (apply-key key ,seq-ref)) (return ,return))))) (defmacro vector-locater (item sequence return-type) `(vector-locater-macro ,sequence (locater-test-not ,item ,sequence :vector ,return-type) ,return-type)) (defmacro locater-if-test (test sequence seq-type return-type sense) (let ((seq-ref (case return-type (:position (case seq-type (:vector `(aref ,sequence index)) (:list `(pop ,sequence)))) (:element 'current))) (return (case return-type (:position 'index) (:element 'current)))) (if sense `(if (funcall ,test (apply-key key ,seq-ref)) (return ,return)) `(if (not (funcall ,test (apply-key key ,seq-ref))) (return ,return))))) (defmacro vector-locater-if-macro (test sequence return-type sense) `(vector-locater-macro ,sequence (locater-if-test ,test ,sequence :vector ,return-type ,sense) ,return-type)) (defmacro vector-locater-if (test sequence return-type) `(vector-locater-if-macro ,test ,sequence ,return-type t)) (defmacro vector-locater-if-not (test sequence return-type) `(vector-locater-if-macro ,test ,sequence ,return-type nil)) (defmacro list-locater-macro (sequence body-form return-type) `(if from-end (do ((sequence (nthcdr (- (the fixnum (length sequence)) (the fixnum end)) (reverse (the list ,sequence)))) (index (1- (the fixnum end)) (1- index)) (terminus (1- (the fixnum start))) ,@(case return-type (:position nil) (:element '(current)))) ((or (= index terminus) (null sequence)) ()) (declare (fixnum index terminus)) ,@(case return-type (:position nil) (:element `((setf current (pop ,sequence))))) ,body-form) (do ((sequence (nthcdr start ,sequence)) (index start (1+ index)) ,@(case return-type (:position nil) (:element '(current)))) ((or (= index (the fixnum end)) (null sequence)) ()) (declare (fixnum index)) ,@(case return-type (:position nil) (:element `((setf current (pop ,sequence))))) ,body-form))) (defmacro list-locater (item sequence return-type) `(list-locater-macro ,sequence (locater-test-not ,item ,sequence :list ,return-type) ,return-type)) (defmacro list-locater-if-macro (test sequence return-type sense) `(list-locater-macro ,sequence (locater-if-test ,test ,sequence :list ,return-type ,sense) ,return-type)) (defmacro list-locater-if (test sequence return-type) `(list-locater-if-macro ,test ,sequence ,return-type t)) (defmacro list-locater-if-not (test sequence return-type) `(list-locater-if-macro ,test ,sequence ,return-type nil)) ) ; eval-when ;;; Position: (eval-when (compile eval) (defmacro vector-position (item sequence) `(vector-locater ,item ,sequence :position)) (defmacro list-position (item sequence) `(list-locater ,item ,sequence :position)) ) ; eval-when ;;; POSITION cannot default end to the length of sequence since it is not ;;; an error to supply nil for its value. We must test for end being nil ;;; in the body of the function, and this is actually done in the support ;;; routines for other reasons (see below). (defun position (item sequence &key from-end (test #'eql) test-not (start 0) end key) "Returns the zero-origin index of the first element in SEQUENCE satisfying the test (default is EQL) with the given ITEM" (seq-dispatch sequence (list-position* item sequence from-end test test-not start end key) (vector-position* item sequence from-end test test-not start end key))) ;;; The support routines for SUBSEQ are used by compiler transforms, so we ;;; worry about dealing with end being supplied as or defaulting to nil ;;; at this level. (defun list-position* (item sequence from-end test test-not start end key) (declare (fixnum start)) (when (null end) (setf end (length sequence))) (list-position item sequence)) (defun vector-position* (item sequence from-end test test-not start end key) (declare (fixnum start)) (when (null end) (setf end (length sequence))) (vector-position item sequence)) ;;; Position-if: (eval-when (compile eval) (defmacro vector-position-if (test sequence) `(vector-locater-if ,test ,sequence :position)) (defmacro list-position-if (test sequence) `(list-locater-if ,test ,sequence :position)) ) (defun position-if (test sequence &key from-end (start 0) key end) "Returns the zero-origin index of the first element satisfying test(el)" (declare (fixnum start)) (when (null end) (setf end (length sequence))) (seq-dispatch sequence (list-position-if test sequence) (vector-position-if test sequence))) ;;; Position-if-not: (eval-when (compile eval) (defmacro vector-position-if-not (test sequence) `(vector-locater-if-not ,test ,sequence :position)) (defmacro list-position-if-not (test sequence) `(list-locater-if-not ,test ,sequence :position)) ) (defun position-if-not (test sequence &key from-end (start 0) key end) "Returns the zero-origin index of the first element not satisfying test(el)" (declare (fixnum start)) (when (null end) (setf end (length sequence))) (seq-dispatch sequence (list-position-if-not test sequence) (vector-position-if-not test sequence))) ;;; Find: (eval-when (compile eval) (defmacro vector-find (item sequence) `(vector-locater ,item ,sequence :element)) (defmacro list-find (item sequence) `(list-locater ,item ,sequence :element)) ) ;;; FIND cannot default end to the length of sequence since it is not ;;; an error to supply nil for its value. We must test for end being nil ;;; in the body of the function, and this is actually done in the support ;;; routines for other reasons (see above). (defun find (item sequence &key from-end (test #'eql) test-not (start 0) end key) "Returns the first element in SEQUENCE satisfying the test (default is EQL) with the given ITEM" (declare (fixnum start)) (seq-dispatch sequence (list-find* item sequence from-end test test-not start end key) (vector-find* item sequence from-end test test-not start end key)))) ;;; The support routines for FIND are used by compiler transforms, so we ;;; worry about dealing with end being supplied as or defaulting to nil ;;; at this level. (defun list-find* (item sequence from-end test test-not start end key) (when (null end) (setf end (length sequence))) (list-find item sequence)) (defun vector-find* (item sequence from-end test test-not start end key) (when (null end) (setf end (length sequence))) (vector-find item sequence)) ;;; Find-if: (eval-when (compile eval) (defmacro vector-find-if (test sequence) `(vector-locater-if ,test ,sequence :element)) (defmacro list-find-if (test sequence) `(list-locater-if ,test ,sequence :element)) ) (defun find-if (test sequence &key from-end (start 0) end key) "Returns the zero-origin index of the first element satisfying the test." (declare (fixnum start)) (when (null end) (setf end (length sequence))) (seq-dispatch sequence (list-find-if test sequence) (vector-find-if test sequence))) ;;; Find-if-not: (eval-when (compile eval) (defmacro vector-find-if-not (test sequence) `(vector-locater-if-not ,test ,sequence :element)) (defmacro list-find-if-not (test sequence) `(list-locater-if-not ,test ,sequence :element)) ) (defun find-if-not (test sequence &key from-end (start 0) end key) "Returns the zero-origin index of the first element not satisfying the test." (declare (fixnum start)) (when (null end) (setf end (length sequence))) (seq-dispatch sequence (list-find-if-not test sequence) (vector-find-if-not test sequence))) ;;; Count: (eval-when (compile eval) (defmacro vector-count (item sequence) `(do ((index start (1+ index)) (count 0)) ((= index (the fixnum end)) count) (declare (fixnum index count)) (if test-not (if (funcall test-not ,item (apply-key key (aref ,sequence index))) (setq count (1+ count))) (if (funcall test ,item (apply-key key (aref ,sequence index))) (setq count (1+ count)))))) (defmacro list-count (item sequence) `(do ((sequence (nthcdr start ,sequence)) (index start (1+ index)) (count 0)) ((or (= index (the fixnum end)) (null sequence)) count) (declare (fixnum index count)) (if test-not (if (funcall test-not ,item (apply-key key (pop sequence))) (setq count (1+ count))) (if (funcall test ,item (apply-key key (pop sequence))) (setq count (1+ count)))))) ) (defun count (item sequence &key from-end (test #'eql) test-not (start 0) end key) "Returns the number of elements in SEQUENCE satisfying a test with ITEM, which defaults to EQL." (declare (ignore from-end) (fixnum start)) (when (null end) (setf end (length sequence))) (seq-dispatch sequence (list-count item sequence) (vector-count item sequence))) ;;; Count-if: (eval-when (compile eval) (defmacro vector-count-if (predicate sequence) `(do ((index start (1+ index)) (count 0)) ((= index (the fixnum end)) count) (declare (fixnum index count)) (if (funcall ,predicate (apply-key key (aref ,sequence index))) (setq count (1+ count))))) (defmacro list-count-if (predicate sequence) `(do ((sequence (nthcdr start ,sequence)) (index start (1+ index)) (count 0)) ((or (= index (the fixnum end)) (null sequence)) count) (declare (fixnum index count)) (if (funcall ,predicate (apply-key key (pop sequence))) (setq count (1+ count))))) ) (defun count-if (test sequence &key from-end (start 0) end key) "Returns the number of elements in SEQUENCE satisfying TEST(el)." (declare (ignore from-end) (fixnum start)) (when (null end) (setf end (length sequence))) (seq-dispatch sequence (list-count-if test sequence) (vector-count-if test sequence))) ;;; Count-if-not: (eval-when (compile eval) (defmacro vector-count-if-not (predicate sequence) `(do ((index start (1+ index)) (count 0)) ((= index (the fixnum end)) count) (declare (fixnum index count)) (if (not (funcall ,predicate (apply-key key (aref ,sequence index)))) (setq count (1+ count))))) (defmacro list-count-if-not (predicate sequence) `(do ((sequence (nthcdr start ,sequence)) (index start (1+ index)) (count 0)) ((or (= index (the fixnum end)) (null sequence)) count) (declare (fixnum index count)) (if (not (funcall ,predicate (apply-key key (pop sequence)))) (setq count (1+ count))))) ) (defun count-if-not (test sequence &key from-end (start 0) end key) "Returns the number of elements in SEQUENCE not satisfying TEST(el)." (declare (ignore from-end) (fixnum start)) (when (null end) (setf end (length sequence))) (seq-dispatch sequence (list-count-if-not test sequence) (vector-count-if-not test sequence))) ;;; Mismatch utilities: (eval-when (compile eval) (defmacro match-vars (&rest body) `(let ((inc (if from-end -1 1)) (start1 (if from-end (1- (the fixnum end1)) start1)) (start2 (if from-end (1- (the fixnum end2)) start2)) (end1 (if from-end (1- (the fixnum start1)) end1)) (end2 (if from-end (1- (the fixnum start2)) end2))) (declare (fixnum inc start1 start2 end1 end2)) ,@body)) (defmacro matchify-list (sequence start length end) `(setq ,sequence (if from-end (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1) (reverse (the list ,sequence))) (nthcdr ,start ,sequence)))) ) ;;; Mismatch: (eval-when (compile eval) (defmacro if-mismatch (elt1 elt2) `(cond ((= (the fixnum index1) (the fixnum end1)) (return (if (= (the fixnum index2) (the fixnum end2)) nil (if from-end (1+ (the fixnum index1)) (the fixnum index1))))) ((= (the fixnum index2) (the fixnum end2)) (return (if from-end (1+ (the fixnum index1)) index1))) (test-not (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) (return (if from-end (1+ (the fixnum index1)) index1)))) (t (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) (return (if from-end (1+ (the fixnum index1)) index1)))))) (defmacro mumble-mumble-mismatch () `(do ((index1 start1 (+ index1 (the fixnum inc))) (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (aref sequence1 index1) (aref sequence2 index2)))) (defmacro mumble-list-mismatch () `(do ((index1 start1 (+ index1 (the fixnum inc))) (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (aref sequence1 index1) (pop sequence2)))) (defmacro list-mumble-mismatch () `(do ((index1 start1 (+ index1 (the fixnum inc))) (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (pop sequence1) (aref sequence2 index2)))) (defmacro list-list-mismatch () `(do ((index1 start1 (+ index1 (the fixnum inc))) (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) (if-mismatch (pop sequence1) (pop sequence2)))) ) (defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not (start1 0) end1 (start2 0) end2 key) "The specified subsequences of Sequence1 and Sequence2 are compared element-wise. If they are of equal length and match in every element, the result is Nil. Otherwise, the result is a non-negative integer, the index within Sequence1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within Sequence1 beyond the last position tested is returned. If a non-Nil :From-End keyword argument is given, then one plus the index of the rightmost position in which the sequences differ is returned." (declare (fixnum start1 start2)) (when (null end1) (setf end1 (length sequence1))) (when (null end2) (setf end2 (length sequence2))) (let ((length1 (length sequence1)) (length2 (length sequence2))) (declare (fixnum length1 length2)) (match-vars (seq-dispatch sequence1 (progn (matchify-list sequence1 start1 length1 end1) (seq-dispatch sequence2 (progn (matchify-list sequence2 start2 length2 end2) (list-list-mismatch)) (list-mumble-mismatch))) (seq-dispatch sequence2 (progn (matchify-list sequence2 start2 length2 end2) (mumble-list-mismatch)) (mumble-mumble-mismatch)))))) ;;; Search comparison functions: (eval-when (compile eval) ;;; Compare two elements and return if they don't match: (defmacro compare-elements (elt1 elt2) `(if test-not (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2)) (return nil) t) (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2))) (return nil) t))) (defmacro search-compare-list-list (main sub) `(do ((main ,main (cdr main)) (jndex start1 (1+ jndex)) (sub (nthcdr start1 ,sub) (cdr sub))) ((or (null main) (null sub) (= (the fixnum end1) jndex)) t) (declare (fixnum jndex)) (compare-elements (car main) (car sub)))) (defmacro search-compare-list-vector (main sub) `(do ((main ,main (cdr main)) (index start1 (1+ index))) ((or (null main) (= index (the fixnum end1))) t) (declare (fixnum index)) (compare-elements (car main) (aref ,sub index)))) (defmacro search-compare-vector-list (main sub index) `(do ((sub (nthcdr start1 ,sub) (cdr sub)) (jndex start1 (1+ jndex)) (index ,index (1+ index))) ((or (= (the fixnum end1) jndex) (null sub)) t) (declare (fixnum jndex index)) (compare-elements (aref ,main index) (car sub)))) (defmacro search-compare-vector-vector (main sub index) `(do ((index ,index (1+ index)) (sub-index start1 (1+ sub-index))) ((= sub-index (the fixnum end1)) t) (declare (fixnum sub-index index)) (compare-elements (aref ,main index) (aref ,sub sub-index)))) (defmacro search-compare (main-type main sub index) (if (eq main-type 'list) `(seq-dispatch ,sub (search-compare-list-list ,main ,sub) (search-compare-list-vector ,main ,sub)) `(seq-dispatch ,sub (search-compare-vector-list ,main ,sub ,index) (search-compare-vector-vector ,main ,sub ,index)))) ) (eval-when (compile eval) (defmacro list-search (main sub) `(do ((main (nthcdr start2 ,main) (cdr main)) (index2 start2 (1+ index2)) (terminus (- (the fixnum end2) (the fixnum (- (the fixnum end1) (the fixnum start1))))) (last-match ())) ((> index2 terminus) last-match) (declare (fixnum index2 terminus)) (if (search-compare list main ,sub index2) (if from-end (setq last-match index2) (return index2))))) (defmacro vector-search (main sub) `(do ((index2 start2 (1+ index2)) (terminus (- (the fixnum end2) (the fixnum (- (the fixnum end1) (the fixnum start1))))) (last-match ())) ((> index2 terminus) last-match) (declare (fixnum index2 terminus)) (if (search-compare vector ,main ,sub index2) (if from-end (setq last-match index2) (return index2))))) ) (defun search (sequence1 sequence2 &key from-end (test #'eql) test-not (start1 0) end1 (start2 0) end2 key) "A search is conducted using EQL for the first subsequence of sequence2 which element-wise matches sequence1. If there is such a subsequence in sequence2, the index of the its leftmost element is returned; otherwise () is returned." (declare (fixnum start1 start2)) (when (null end1) (setf end1 (length sequence1))) (when (null end2) (setf end2 (length sequence2))) (seq-dispatch sequence2 (list-search sequence2 sequence1) (vector-search sequence2 sequence1)))