;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10 -*-
;;;
;;; Sequence Functions
;;;
;;; Functions
;;; CONCATENATE COPY-SEQ COUNT COUNT-IF COUNT-IF-NOT DELETE DELETE-DUPLICATES
;;; DELETE-IF DELETE-IF-NOT ELT EVERY FILL FIND FIND-IF FIND-IF-NOT LENGTH
;;; MAKE-SEQUENCE MAP MERGE MISMATCH NOTANY NOTEVERY NREVERSE NSUBSTITUTE
;;; NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT POSITION POSITION-IF POSITION-IF-NOT
;;; REDUCE REMOVE REMOVE-DUPLICATES REMOVE-IF REMOVE-IF-NOT REPLACE REVERSE
;;; SEARCH SOME SORT STABLE-SORT SUBSEQ SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT
;;; 
;;;

(defun check-sequence-args (sequence start end
			    &optional (q 'sequence) (s 'start) (e 'end))
  (let ((tem (typecase sequence
	       (list
		(or (list-length sequence)
		    end
		    (error "The sequence ~S is circular" sequence)))
	       (vector
		(length sequence))
	       (t
		(error "The ~S argument, ~S, is not a sequence (a list or a vector)"
			q sequence)))))
    (or end (setq end tem))
    (check-type start (integer 0))
    (check-type end (integer 0))
    (unless (<= 0 start tem)
      (error "The ~S argument, ~S, is out of range. (0 - ~S)" s start tem))
    (unless (<= 0 end tem)
      (error "The ~S argument, ~S, is out of range. (0 - ~S)" e end tem))
    (unless (<= start end)
      (error "The ~S argument, ~S, is greater than ~S (~S)" s start e end))
    (values tem
	    ;; seq-start
	    (if (listp sequence) (setq tem (nthcdr start sequence)) start)
	    ;; seq-end
	    (if (listp sequence) (nthcdr (- end start) tem) end))))


;;; Primitives for fetching elements sequentially from either lists or arrays.
;;; You use an index variable which contains an array index if the
;;; sequence is an array, or a tail if the sequence is a list.

(defmacro seq-inc (indexvar)
  `(if (typep ,indexvar 'fixnum)
       (incf ,indexvar)
     (setq ,indexvar (cdr ,indexvar))))

(defmacro seq-fetch (sequence indexvar)
  `(if (typep ,indexvar 'fixnum)
       (aref ,sequence ,indexvar)
     (car ,indexvar)))

(defmacro seq-fetch-inc (sequence indexvar)
  `(if (typep ,indexvar 'fixnum)
       (aref ,sequence (prog1 ,indexvar (incf ,indexvar)))
     (pop ,indexvar)))

(defmacro key-fetch (key sequence indexvar)
  `(let ((tem (if (typep ,indexvar 'fixnum)
		  (aref ,sequence ,indexvar)
		(car ,indexvar))))
     (if ,key (funcall ,key tem) tem)))

(defmacro key-fetch-inc (key sequence indexvar)
  `(let ((tem (if (typep ,indexvar 'fixnum)
		  (aref ,sequence (prog1 ,indexvar (incf ,indexvar)))
		(pop ,indexvar))))
     (if ,key (funcall ,key tem) tem)))

(defmacro seq-store (sequence indexvar value)
  `(if (typep ,indexvar 'fixnum)
       (setf (aref ,sequence ,indexvar) ,value)
     (setf (car ,indexvar) ,value)))

;;; This returns an index variable value that is ready to fetch the
;;; first element of the sequence.

(defmacro seq-start (sequence &optional numeric-index)
  (if numeric-index
      `(if (arrayp ,sequence)
	   ,numeric-index
	 (nthcdr ,numeric-index ,sequence))
    `(if (arrayp ,sequence) 0 ,sequence)))

;;; This returns a value for use in an end-test.
;;; Compare the index var against this value with EQ to see if you are at the end.
(defmacro seq-end (sequence &optional numeric-index)
  `(if (arrayp ,sequence)
       (or ,numeric-index (length ,sequence))
     (and ,numeric-index (nthcdr ,numeric-index ,sequence))))

;;; Macro used by merge and I am sure some other functions
;;;

(defmacro apply-predicate-and-key (lpred keyfun arg1 arg2)
  `(cond ((null ,keyfun) (funcall ,lpred ,arg1 ,arg2))
	 ((eq ,keyfun #'car) (funcall ,lpred (car ,arg1) (car ,arg2)))
	 (t (funcall ,lpred (funcall ,keyfun ,arg1)
		     (funcall ,keyfun ,arg2)))))



;--------------------------------------------------------------------------------

(defun ELT (seq index)
  (cond
    ((arrayp seq)
     (array:svref seq index))
    ((consp seq)
     (dotimes (i index)
       (setq seq (cons:cdr seq)))
     (cons:car seq))
    (t (error "~a is not a sequence." seq))))


;(defun elt (sequence index)
;  "Returns element at position index in sequence. Sequence must be a vector or a list."
;  (etypecase sequence
;    (vector (aref sequence index))
;    (list (nth index sequence))
;    )
;  )

(defun SUBSEQ (seq start &optional end)
  (unless end (setq end (length seq)))
  (let* ((new-length (- end start))
	 (new-seq    (make-sequence (type-of-sequence seq) new-length)))
    (cond
      ((arrayp seq)
       (dotimes (i new-length)
	 (setf (svref new-seq i) (svref seq (+ i start)))))
      ((consp seq)
       (do ((i 0 (1+ i))
	    (from seq     (nthcdr seq start))
	    (to   new-seq (cdr new-seq)))
	   ((= i end))
	 (setf (car to) (car from)))))
    new-seq))

(defun COPY-SEQ (seq)
  (subseq seq 0))

(defun type-of-sequence (seq)
  (cond
    ((consp seq)  'LIST)
    ((vectorp seq)
     (if (stringp seq)
	 'STRING
       (list 'VECTOR (array-element-type seq))))
    (t (li:tail-error "Not a sequence." seq))))

(defun REVERSE (sequence)
  "Return a sequence whose elements are those of SEQUENCE, in reverse order.
If SEQUENCE is a list, the value is a list.
If it is an array, the value is an array of the same type."
  (etypecase sequence
    (list
     (do ((v '())
	  (s sequence (cdr s)))
	 ((endp s) v)
       (push (car s) v)))
    (array
     (let* ((len (length sequence))
	    (result (make-array len :element-type (array-element-type sequence))))
       (dotimes (i len)
	 (setf (aref result i)
	       (aref sequence (- len i 1))))
       result))))
	  
(defun NREVERSE (sequence)
  "Alter SEQUENCE destructively to contain its elements in reverse order.
If SEQUENCE is a list, this works by changing cdr pointers.
If SEQUENCE is an array, this works by shuffling the elements."
  (etypecase sequence
    (list
     (nreconc sequence nil))
    (array
     (let* ((len (length sequence))
	    (halflen (truncate len 2)))
       (dotimes (i halflen)
	 (let ((tem (aref sequence i)))
	   (setf (aref sequence i)
		 (aref sequence (- len i 1)))
	   (setf (aref sequence (- len i 1)) tem)))
       sequence))))

(defun MAKE-SEQUENCE (type size &key (initial-element nil initial-element-p))
  "Returns a sequence of SIZE elements, of type TYPE.
Each element is set to INITIAL-ELEMENT.
TYPE must be equivalent to either LIST or some sort of ARRAY."
  (check-type size (fixnum 0))
  (cond ((eq type 'list)
	 (make-list size :initial-element initial-element))
	((or (member type '(array simple-array vector simple-vector))
	     (and (consp type)
		  (member (car type) '(array simple-array vector simple-vector))
		  (equal (cadr type) '(t))))
	 (make-array size :initial-element initial-element))
	((member type '(string simple-string))
	 (if initial-element-p
	     (make-string size :initial-element initial-element)
	   (make-string size)))
	(t
	 (let ((xtype (type-canonicalize type nil nil)))
	   (cond ((eq xtype 'list)
		  (make-list size :initial-element initial-element))
		 ((or (member xtype '(array simple-array))
		      (and (consp xtype) (member (car xtype) '(array simple-array))
			   (equal (cdr xtype) '(t))))
		  (make-array size :initial-value initial-element))
		 ((and (consp xtype)
		       (member (car xtype) '(array simple-array))
		       (null (cddr xtype)))
		  (if initial-element-p
		      (make-array size :element-type (cadr xtype)
				  :initial-element initial-element)
		    (make-array size :element-type (cadr xtype))))

		 (t
		  (error "Invalid sequence type ~S." type)))))))


;--------------------------------------------------------------------------------

(defun CONCATENATE (result-type &rest sequences)
  "Return a sequence of type RESULT-TYPE concatenating the contents of the SEQUENCES.
Each sequence argument may be a list or an array.
RESULT-TYPE must be a valid sequence type such as LIST or VECTOR."
  (let ((rlen 0))
    (dolist (s sequences)
      (incf rlen (sequence-length s)))
    (let ((result (make-sequence result-type rlen)))
      (let ((store-index (seq-start result)))
	(dolist (s sequences)
	  (if (and (arrayp result) (arrayp s))
	      (let ((len (length s)))
		(array:copy-array-portion s 0 len
					  result store-index (+ store-index len))
		(incf store-index len))
	    (do ((fetch-index (seq-start s))
		 (fetch-end (seq-end s)))
		((eq fetch-index fetch-end))
	      (seq-store result store-index
			 (seq-fetch-inc s fetch-index))
	      (seq-inc store-index)))))
      result)))

(defun MAP (result-type func &rest sequences)
  "Return a sequence of type RESULT-TYPE that is the result of func across the sequences.
Each sequence argument may be a list or an array.
RESULT-TYPE must be a valid sequence type such as LIST or VECTOR."
  (if (cdr sequences)
      (error "Can't do hairy MAP yet")
    (do* ((seq (car sequences))
	  (fetch-index (seq-start seq))
	  (fetch-end   (seq-end seq))
	  (result (make-sequence result-type (length seq)))
	  (result-index (seq-start result)))
	((eq fetch-end fetch-index) result)
      (seq-store result result-index
		 (funcall func (seq-fetch-inc seq fetch-index))))))


(defmacro define-seq-predicate (name test-value stop-value end-value &optional doc)
  `(PROGN
     (DEFUN ,name (PREDICATE SEQUENCE &REST MORE-SEQUENCES)
       ,@(if doc `(,doc))
       (IF MORE-SEQUENCES
	   (SEQ-PREDICATE PREDICATE SEQUENCE MORE-SEQUENCES ,test-value ,stop-value ,end-value)
	 (SEQ-PREDICATE-1 PREDICATE SEQUENCE ,test-value ,stop-value ,end-value)))
     (DEFREWRITE ,name (&WHOLE FORM PREDICATE SEQUENCE)
       (IF (CDDDR FORM)
	   FORM
	 `(SEQ-PREDICATE-1 ,predicate ,sequence ,',test-value ,',stop-value ,',end-value)))))

;;; Yes, END-VALUE is computable from STOP-VALUE, but it would be slower
;;; to invert than to pass it in.

(define-seq-predicate SOME      T   T  NIL
  "Applies PREDICATE to successive elements of of SEQUENCE and SEQUENCES;
if it returns non-NIL, so does SOME. PREDICATE gets one argument from each sequence;
first element 0 of each sequence, then element 1, and so on.
If PREDICATE returns non-NIL, the value it returns is returned by SOME.
If one of the sequences is exhausted, SOME returns NIL.")

(define-seq-predicate EVERY    NIL NIL  T   
"Applies PREDICATE to successive elements of sequence and SEQUENCES;
T if PREDICATE always returns T. PREDICATE gets one argument from each sequence;
first element 0 of each sequence, then element 1, and so on.
If PREDICATE returns NIL, then EVERY returns NIL.
If one of the sequences is exhausted, EVERY returns T.")

(define-seq-predicate NOTANY    T  NIL  T
  "Applies PREDICATE to successive elements of sequence and SEQUENCES;
T if PREDICATE always returns NIL. PREDICATE gets one argument from each sequence;
first element 0 of each sequence, then element 1, and so on.
If PREDICATE returns non-NIL, then NOTANY returns NIL.
If one of the sequences is exhausted, NOTANY returns T.")

(define-seq-predicate NOTEVERY NIL  T  NIL
  "Applies PREDICATE to successive elements of SEQUENCE and SEQUENCES;
T if PREDICATE ever returns NIL. PREDICATE gets one argument from each sequence;
first element 0 of each sequence, then element 1, and so on.
If PREDICATE returns NIL, then NOTEVERY returns T.
If one of the sequences is exhausted, NOTEVERY returns NIL.")  

(defun seq-predicate (pred sequence more-sequences test-value stop-value end-value)
  (error "multi arg sequence predicates not yet implemented"))

(defun seq-predicate-1 (pred seq test-value stop-value end-value)
  (etypecase seq
    (list (do ((tail seq (cdr tail)))
	      ((null tail) end-value)
	    (let ((elt (car tail)))
	      (let ((result (funcall pred elt)))
		(when (if test-value result (not result))
		  (return-from seq-predicate-1 stop-value))))))
    (vector (do ((index 0 (1+ index))
		 (stop-index (length seq)))
		((>= index stop-index) end-value)
	      (let ((elt (aref seq index)))
		(let ((result (funcall pred elt)))
		  (when (if test-value result (not result))
		    (return-from seq-predicate-1 stop-value))))))))

;;; This function used to have ACCUM bound in two clauses of
;;; the cond. The fleabit compiler performed some faulty lifetime 
;;; analysis and determined that there were 1 too many variables and args.
;;; the end result was faulty code. Don't change this back.
;;; ||| Hacked even more to avoid compiler lossage 22sep88 Jim
(defun REDUCE (function sequence &key from-end (start 0) end (initial-value nil initp) &aux tem)
  "Combine the elements of SEQUENCE using FUNCTION, a function of two args.
FUNCTION is applied to the first two elements; then to that result and the third element;
 then to that result and the fourth element; and so on.
START and END restrict the action to a part of SEQUENCE,
 as if the rest of SEQUENCE were not there.  They default to 0 and NIL
 (NIL for END means to the end of SEQUENCE).
If FROM-END is non-NIL, FUNCTION is applied to the last two elements;
 then to the previous element and that result; then to the previous
 element and that result; and so on.
If INITIAL-VALUE is specified, it acts like an extra element of SEQUENCE
 at the end (if FROM-END is non-NIL) or the beginning, in addition to
 the actual elements of the specified part of SEQUENCE.  Then there is
 effectively one more element to be processed.  The INITIAL-VALUE is
 used in the first call to FUNCTION.
If there is only one element to be processed,
 that element is returned and FUNCTION is not called.
If there are no elements (SEQUENCE is of length zero and no INITIAL-VALUE),
 FUNCTION is called with no arguments and its value is returned."
  (multiple-value-bind (length seq-start seq-end)
      (check-sequence-args sequence start end)
    (cond ((eql length 0)
	   (if initp initial-value (funcall function)))
	  ((eql length 1)
	   (setq tem (elt sequence 0))
	   (if initp
	       (if from-end
		   (funcall function tem initial-value)
		 (funcall function initial-value tem))
	     tem))
	  (from-end
	   (reduce-from-end function sequence start end initial-value initp seq-start seq-end length))
	  (t
	   (reduce-normal-case function sequence start end initial-value initp seq-start seq-end length)))))

(defun reduce-normal-case (function sequence start end initial-value initp seq-start seq-end length &aux accum seq-inc)
  (setq seq-inc (seq-fetch-inc sequence seq-start))
  (if initial-value
      (setq accum (funcall function initial-value seq-inc))
    (setq accum (funcall function seq-inc)))
  (do ((index seq-start))
      ((eq index seq-end)
       accum)
    (setq seq-inc (seq-fetch-inc sequence index))
    (setq accum (funcall function accum seq-inc))))

(defun reduce-from-end (function sequence start end initial-value initp seq-start seq-end length &aux tem accum)
       (cond ((vectorp sequence)
	      (setq accum (if initial-value
			      (funcall function (aref sequence (decf seq-end))
				       initial-value)
			    (progn
			      (decf seq-end 2)
			      (funcall function (aref sequence seq-end)
				       (aref sequence (1+ seq-end))))))
	      (do ((index (1- seq-end) (1- index)))
		  ((< index start)
		   accum)
		(setq accum (funcall function (aref sequence index) accum))))
	     (t
	      (labels
		((reduce-list-backwards (function list length initial initp)
					(if (null (cdr list))
					    (if initp (funcall function (car list) initial) (car list))
					  (funcall function
						   (car list)
						   (reduce-list-backwards function
									  (cdr list)
									  (1- length)
									  initial initp)))))
		(reduce-list-backwards function seq-start
				       length initial-value initp)))))

;--------------------------------------------------------------------------------
;;;; Modifying Sequences

(defun FILL (sequence item &key (start 0) end)
  "Set all the elements of SEQUENCE (or some subsequence of it) to ITEM.
START and END specify the subsequence; they default to 0 and NIL
\(NIL for END means to the end of SEQUENCE)."
  (multiple-value-bind (ignore start end)
      (check-sequence-args sequence start end)
    (if (arrayp sequence)
	(array-initialize sequence item start end)
      (do ((tail start (cdr tail)))
	  ((eq tail end))
	(setf (car tail) item))))
  sequence)


(defun replace-1 (into-sequence-1 from-sequence-2 &optional (start1 0) end1 (start2 0) end2)
  (or end1 (setq end1 (length into-sequence-1)))
  (or end2 (setq end2 (length from-sequence-2)))
  (if (eq into-sequence-1 from-sequence-2)
      (let* ((n-copy (min (- end2 start2) (- end1 start1)))
	     (temp (make-list n-copy)))
	(replace-1 temp from-sequence-2 0 n-copy start2 end2)
	(replace-1 into-sequence-1 temp start1 end1 0 n-copy))
    (if (and (vectorp into-sequence-1) (vectorp from-sequence-2))
	(let ((n-copy (min (- end2 start2) (- end1 start1))))
	  (array:copy-array-portion from-sequence-2 start2 (+ start2 n-copy)
				    into-sequence-1 start1 (+ start1 n-copy)))
      (let ((store-index (if (arrayp into-sequence-1) start1 (nthcdr start1 into-sequence-1)))
	    (store-end (if (arrayp into-sequence-1) end1 (nthcdr end1 into-sequence-1)))
	    ;; ||| Commented out to get aroundd compiler bug Jim 22sep88
	    ;;(fetch-end (if (arrayp from-sequence-2) end2 (nthcdr end2 from-sequence-2)))
	    (fetch-index (if (arrayp from-sequence-2) start2 (nthcdr start2  from-sequence-2))))
	(do ()
	    ((or (eq store-index store-end)
		 ;; ||| Commented out to get around compiler bug Jim 22sep88
		 ;; (eq fetch index fetch-end)))
		 (eq fetch-index (if (arrayp from-sequence-2) end2 (nthcdr end2 from-sequence-2)))))
	  (seq-store into-sequence-1 store-index (seq-fetch-inc from-sequence-2 fetch-index))
	  (seq-inc store-index)))))
  into-sequence-1
  )

(defun REPLACE (into-sequence-1 from-sequence-2 &key (start1 0) end1 (start2 0) end2)
  "Copy all or part of FROM-SEQUENCE-2 into INTO-SEQUENCE-1.
A sequence is either a list or a vector.
START1 and END1 specify the part of FROM-SEQUENCE-2 to be copied.
 They default to 0 and NIL (which means the end of the sequence).
START2 and END2 specify the part of INTO-SEQUENCE-1 to be copied into.
If the subsequence to be copied into is longer than the one to be copied,
 the extra elements of the to-subsequence are left unchanged.
If the two sequences are the same, the data is first copied to a
 intermediate location and then copied back in.
The value is INTO-SEQUENCE-1."
  (check-type into-sequence-1 sequence)
  (check-type from-sequence-2 sequence)
  (replace-1 into-sequence-1 from-sequence-2 start1 end1 start2 end2)
  )

(defun remove-from-array (item vector start end count test invertp key from-end one-arg-predicate)
  (or end (setq end (length vector)))
  (or count (setq count (length vector)))
  ;; collect all the indices of element to be removed.
  (let ((temp nil)
	(start-index (if from-end (1- end) start))
	(stepping-index (if from-end -1 1))
	(number-of-elements-collected 0)
	result elt)
    (do ((index start-index (+ index stepping-index)))
	((or (if from-end (>= index end) (< index start))
	     (>= number-of-elements-collected count))
	 (or from-end (setq temp (nreverse temp))))
      (setq elt (if key (funcall key (aref vector index)) (aref vector index)))
      (when (eq invertp (not (cond (one-arg-predicate
				    (funcall one-arg-predicate elt))
				   (test (funcall test elt item))
				   (t (eql elt item)))))
	(setq temp (cons index temp))
	(incf number-of-elements-collected)))
    ;; if temp is nil then nothing has been found and just return the same array.
    (if (null temp)
	vector
      (setq result (remove-from-array-internal temp vector number-of-elements-collected)))
    result))

(defun remove-from-array-internal (temp vector number-of-elements-collected &aux result)
;;; some elements have been found, we must then delete them from the sequence.
;;; Now TEMP contains the indices of the elements to be removed, in ascending order.
  (setq result (make-array (- (length vector) number-of-elements-collected)
			   :element-type (array-element-type vector)))
  (do* ((start-from 0 (1+ (car tmp)))
	(tmp temp (cdr tmp))
	(to-from (car tmp) (or (car tmp) (length vector)))
	(start-dest 0 (+ start-dest number-of-elements))
	(number-of-elements (- to-from start-from) (- to-from start-from)))
       ((null tmp)
	;; remainding elements in vector have to be copied over to result
	(array:copy-array-portion vector start-from to-from
				  result start-dest (length result))
	result)
    (array:copy-array-portion vector start-from to-from
			      result start-dest (+ start-dest number-of-elements))))

(defun remove-from-list (item list start end count test invertp key
			 from-end one-arg-predicate &aux (skip-count 0))
  (when (and from-end
	     count
             (not (and end (>= count (- end start)))))
    (setq skip-count (max 0 (- (count-1 item list start end test invertp
					key one-arg-predicate)
			       count))))
  ;; This ugly variable hacking is needed to avoid exceeding 15 locals.
  (let (ok-to new-head new-pointer)
    (setq new-head (if start (nthcdr start list) list)
	  new-pointer (if end (nthcdr (- end start) new-head) nil)
	  start new-head
	  end new-pointer
	  new-head nil
	  new-pointer nil)
    (do* ((tail start (cdr tail))
	  (elt (if key (funcall key (car tail)) (car tail))
	       (if key (funcall key (car tail)) (car tail))))
	 ((eq tail end))
      (when (eq invertp (not (cond (one-arg-predicate
				    (funcall one-arg-predicate elt))
				   (test
				    (funcall test item elt))
				   (t
				    (eql item elt)))))
	(if (plusp skip-count)
	    (decf skip-count)
	  (if (if count
		  (when (plusp count)
		    (decf count) t)
		t)
	      (progn
		;; append from LIST to TAIL onto NEW-HEAD
		(do ((l list (cdr l)))
		    ((eq l tail))
		  (let ((new (cons (car l) nil)))
		    (if new-head
			(setf (cdr new-pointer) new)
		      (setq new-head new))
		    (setq new-pointer new)))
		(setq list (cdr tail)))
	    (return)))))
    (if new-head
	(progn
	  (setf (cdr new-pointer) list)
	  new-head)
      list)))

(defun remove-from-list-eq (item list)
  (let ((ok-to list))
    (let ((new-head nil)
	  (new-pointer nil))
      (do ((tail list (cdr tail)))
	  ((endp tail))
	(when (eq item (car tail))
	  ;; append from OK-TO to TAIL onto NEW-HEAD
	  (do ((l ok-to (cdr l)))
	      ((eq l tail))
	    (let ((new (cons (car l) nil)))
	      (if new-head
		  (setf (cdr new-pointer) new)
		(setq new-head new))
	      (setq new-pointer new)))
	  (setq ok-to (cdr tail))))
      (if new-head
	  (progn
	    (setf (cdr new-pointer) ok-to)
	    new-head)
	ok-to))))

(defun remove-from-list-eql (item list)
  (let ((ok-to list))
    (let ((new-head nil)
	  (new-pointer nil))
      (do ((tail list (cdr tail)))
	  ((endp tail))
	(when (eql item (car tail))
	  ;; append from OK-TO to TAIL onto NEW-HEAD
	  (do ((l ok-to (cdr l)))
	      ((eq l tail))
	    (let ((new (cons (car l) nil)))
	      (if new-head
		  (setf (cdr new-pointer) new)
		(setq new-head new))
	      (setq new-pointer new)))
	  (setq ok-to (cdr tail))))
      (if new-head
	  (progn
	    (setf (cdr new-pointer) ok-to)
	    new-head)
	ok-to))))


(defun REMOVE-IF (predicate sequence &key (start 0) end count key from-end)
  "Return SEQUENCE, partially copied so that elements satisfying PREDICATE are omitted.
START and END specify a subsequence to consider; elements outside
 that subsequence will not be removed even if they would satisfy PREDICATE.
 They default to 0 and NIL (which means the end of the sequence).
KEY, if non-NIL, is a function to be applied to each element
 to get the object to pass to the PREDICATE.  If KEY is NIL,
 the element itself is passed to the PREDICATE.
COUNT can be used to specify how many elements to remove (at maximum);
 after that many have been found, the rest are left alone.
FROM-END, if non-NIL, means that the last COUNT matching elements
 should be removed, rather than the first COUNT many."
  (etypecase sequence
    (list (remove-from-list nil sequence start end count nil nil key from-end predicate))
    (vector (remove-from-array nil sequence start end count nil nil key from-end predicate))))

(defun REMOVE-IF-NOT (predicate sequence &key (start 0) end count key from-end)
  "Like REMOVE-IF but removes elements which do not satisfy PREDICATE."
  (etypecase sequence
    (list (remove-from-list nil sequence start end count nil t key from-end predicate))
    (vector (remove-from-array nil sequence start end count nil t key from-end predicate))))


(defun REMOVE (item sequence &key test test-not (start 0) end count key from-end)
  "Return SEQUENCE, partially copied so that elements matching ITEM are omitted.
START and END specify a subsequence to consider; elements outside
 that subsequence will not be removed even if they would match.
 They default to 0 and NIL (which means the end of the sequence).
KEY, if non-NIL, is a function to be applied to each element
 to get the object to match against ITEM.  If KEY is NIL,
 the element itself is matched.
TEST is a function of two args to use to compare ITEM against an element (or key).
 An element matches when the TEST function returns non-NIL.
 Alternatively, specify as TEST-NOT a function to use which returns NIL if there is a match.
COUNT can be used to specify how many elements to remove (at maximum);
 after that many have been found, the rest are left alone.
FROM-END, if non-NIL, means that the last COUNT matching elements
 should be removed, rather than the first COUNT many."
  (etypecase sequence
    (list (remove-from-list item sequence start end count (or test-not test) (not (null test-not)) key from-end nil))
    (vector (remove-from-array item sequence start end count (or test-not test) (not (null test-not))
			       key from-end nil))))

(defun remove-eql (item sequence)
  (etypecase sequence
    (list (remove-from-list-eql item sequence))
    (vector (remove-from-array item sequence 0 nil nil nil nil nil nil nil))))

(defun remove-eq (item sequence)
  (etypecase sequence
    (list (remove-from-list-eq item sequence))
    (vector (remove-from-array item sequence 0 nil nil #'eq nil nil nil nil))))

(def-rewrite-patterns remove (item sequence)
  (()                  `(REMOVE-EQL ,item ,sequence))
  ((&key (test #'eq))  `(REMOVE-EQ ,item ,sequence))
  ((&key (test #'eql)) `(REMOVE-EQL ,item ,sequence)))


(defun delete-from-list (item list start end count test invertp key from-end
			 one-arg-predicate &aux (skip-count 0))
  (when (and from-end
	     count
             (not (and end (>= count (- end start)))))
      (setq skip-count (max 0 (- (count-1 item list start end test invertp
					  key one-arg-predicate)
				 count))))
  (let* ((start-tail-1 (if (zerop start)
			  nil
			  (nthcdr (1- start) list)))
	 (start-tail (if start-tail-1
			 (cdr start-tail-1)
		       (nthcdr start list)))
	 (end-tail (if end (nthcdr (- end start) start-tail) nil)))
    (do ((tail start-tail (cdr tail)))
	((eq tail end-tail))
      (let ((elt (if key (funcall key (car tail)) (car tail))))
	(if (eq invertp (not (cond (one-arg-predicate
				    (funcall one-arg-predicate item))
				   (test
				    (funcall test elt item))
				   (t
				    (eql elt item)))))
	  (if (plusp skip-count)
	      (decf skip-count)
	    (if (if count
		    (when (plusp count)
		      (decf count) t)
		  t)
		(if start-tail-1
		    (progn (setf (cdr start-tail-1) (cdr tail))
			   (setq start-tail-1 (cdr tail)))
		  (setq list (cdr tail)))
	      (return)))
	  (setq start-tail-1 tail)))))
  list)

(defun delete-from-list-eql (item list)
  (do ((tail-1 nil)
       (tail list (cdr tail)))
      ((endp tail))
    (if (eql item (car tail))
	(if tail-1
	    (progn (setf (cdr tail-1) (cdr tail))
		   (setq tail-1 (cdr tail)))
	  (setq list (cdr tail)))
      (setq tail-1 tail)))
  list)

(defun delete-from-list-eq (item list)
  (do ((tail-1 nil)
       (tail list (cdr tail)))
      ((endp tail))
    (if (eq item (car tail))
	(if tail-1
	    (progn (setf (cdr tail-1) (cdr tail))
		   (setq tail-1 (cdr tail)))
	  (setq list (cdr tail)))
      (setq tail-1 tail)))
  list)



(defun delete-from-array  (item vector start end count test invertp
			   key from-end one-arg-predicate)
  (remove-from-array item vector start end count test invertp
		     key from-end one-arg-predicate))

(defun DELETE (item sequence &key test test-not (start 0) end count key from-end)
  "Return SEQUENCE, partially copied so that elements matching ITEM are omitted.
START and END specify a subsequence to consider; elements outside
 that subsequence will not be removed even if they would match.
 They default to 0 and NIL (which means the end of the sequence).
KEY, if non-NIL, is a function to be applied to each element
 to get the object to match against ITEM.  If KEY is NIL,
 the element itself is matched.
TEST is a function of two args to use to compare ITEM against an element (or key).
 An element matches when the TEST function returns non-NIL.
 Alternatively, specify as TEST-NOT a function to use which returns NIL if there is a match.
COUNT can be used to specify how many elements to remove (at maximum);
 after that many have been found, the rest are left alone.
FROM-END, if non-NIL, means that the last COUNT matching elements
 should be removed, rather than the first COUNT many."
  (etypecase sequence
    (list (delete-from-list item sequence start end count (or test-not test) (not (null test-not))
			    key from-end nil))
    (vector (delete-from-array item sequence start end count (or test-not test) (not (null test-not))
			       key from-end nil))))

;; fixed ETYPECASE forms for DELETE-EQL and DELETE-EQ
;; to prevent always returning a vector  ||| 27sept88 pfc

(defun delete-eql (item sequence)
  (etypecase sequence
    (list (delete-from-list-eql item sequence))
    (vector (delete-from-array item sequence 0 nil nil nil nil nil nil nil))))

(defun delete-eq (item sequence)
  (etypecase sequence
    (list (delete-from-list-eq item sequence))
    (vector (delete-from-array item sequence 0 nil nil #'eq nil nil nil nil))))

(def-rewrite-patterns delete (item sequence)
  (()                  `(DELETE-EQL ,item ,sequence))
  ((&key (test #'eq))  `(DELETE-EQ ,item ,sequence))
  ((&key (test #'eql)) `(DELETE-EQL ,item ,sequence)))
  
(defun DELETE-IF (predicate sequence &key (start 0) end count key from-end)
  "Return SEQUENCE, modified so that elements satisfying PREDICATE are omitted.
The value may be SEQUENCE itself destructively modified or it may be a copy.
START and END specify a subsequence to consider; elements outside
 that subsequence will not be removed even if they would satisfy PREDICATE.
 They default to 0 and NIL (which means the end of the sequence).
KEY, if non-NIL, is a function to be applied to each element
 to get the object to pass to the PREDICATE.  If KEY is NIL,
 the element itself is passed to the PREDICATE.
COUNT can be used to specify how many elements to remove (at maximum);
 after that many have been found, the rest are left alone.
FROM-END, if non-NIL, means that the last COUNT matching elements
 should be removed, rather than the first COUNT many."
  (etypecase sequence
    (list (delete-from-list nil sequence start end count nil nil key from-end predicate))
    (vector (delete-from-array nil sequence start end count nil nil key from-end predicate))))

(defun DELETE-IF-NOT (predicate sequence &key (start 0) end count key from-end)
  "Like DELETE-IF but deletes elements which do not satisfy PREDICATE."
  (etypecase sequence
    (list (delete-from-list nil sequence start end count nil t key from-end predicate))
    (vector (delete-from-array nil sequence start end count nil t key from-end predicate))))


(defun pos-1 (item vector start end test test-not key)
  (do ((i start (1+ i)))
      ((>= i end) nil)
    (let ((elt (aref vector i)))
      (if key (setq elt (funcall key elt)))
      (when (cond (test
		   (funcall test item elt))
		  (test-not
		   (not (funcall test-not item elt)))
		  (t
		   (eql item elt)))
	(return i)))))

(defun remove-duplicates-from-array (vector start end test test-not key from-end)
  (or end (setq end (length vector)))
  ;; collect all the indices of element to be removed.
  (let ((temp nil)
	(start-index (if from-end (1- end) start))
	(stepping-index (if from-end -1 1))
	(number-of-elements-collected 0)
	result elt ind)
    (do ((index start-index (+ index stepping-index)))
	((if from-end (< index start) (>= index end))
	 (or from-end (setq temp (nreverse temp))))
      (setq elt (if key (funcall key (aref vector index)) (aref vector index)))
      (setq ind
	(if from-end
	    (pos-1 elt vector start index test test-not key)
	  (pos-1 elt vector (1+ index) end test test-not key)))
      (when ind
	(setq temp (cons index temp))
	(incf number-of-elements-collected)))
    ;; if temp is nil then nothing has been found and just return the same array.
    (if (null temp)
	vector
      (setq result (remove-duplicates-from-array-internal temp vector number-of-elements-collected)))
      ;; some elements have been found, we must then delete them from the sequence.
      ;; Now TEMP contains the indices of the elements to be removed, in ascending order.
      result))

(defun remove-duplicates-from-array-internal (temp vector number-of-elements-collected &aux result)
  (setq result (make-array (- (length vector) number-of-elements-collected)
			   :element-type (array-element-type vector)))
  (do* ((start-from 0 (1+ (car tmp)))
	(tmp temp (cdr tmp))
	(to-from (car tmp) (or (car tmp) (length vector)))
	(start-dest 0 (+ start-dest number-of-elements))
	(number-of-elements (- to-from start-from) (- to-from start-from)))
       ((null tmp)
	;; remainding elements in vector have to be copied over to result
	(array:copy-array-portion vector start-from to-from
				  result start-dest (length result))
	result)
    (array:copy-array-portion vector start-from to-from
				    result start-dest (+ start-dest number-of-elements))))

(defun sublist-member (item start-tail end-tail test test-not key)
  (do ((l start-tail (cdr l))
       elt)
      ((eq l end-tail) nil)
    (setq elt (if key (funcall key (car l)) (car l)))
    (when (cond (test
		 (funcall test item elt))
		(test-not
		 (not (funcall test-not item elt)))
		(t (eql item elt)))
      (return t))))

(defun remove-duplicates-from-list (list start end test test-not key from-end)
  (let ((start-tail (if start (nthcdr start list) list)))
    (let ((end-tail (if end (nthcdr (- end start) start-tail) nil)))
      (let ((ok-to list))
	(let ((new-head nil)
	      (new-pointer nil))
	  (do ((tail start-tail (cdr tail)))
	      ((eq tail end-tail) (if new-head
				      (progn
					(setf (cdr new-pointer) ok-to)
					new-head)
				    ok-to))
	    (let ((item (if key (funcall key (car tail)) (car tail))))
	      ;; look for duplicates
	      (when (if from-end
			(sublist-member item start-tail tail test test-not key)
		      (sublist-member item (cdr tail) end-tail test test-not key))
		;; append from OK-TO to TAIL onto NEW-HEAD
		(do ((l ok-to (cdr l)))
		    ((eq l tail))
		  (let ((new (cons (car l) nil)))
		    (if new-head
			(setf (cdr new-pointer) new)
		      (setq new-head new))
		    (setq new-pointer new)))
		(setq ok-to (cdr tail))))))))))
			 
	   
(defun REMOVE-DUPLICATES (sequence &key (start 0) end key from-end test test-not)
  "Returns SEQUENCE, partially copied if necessary, omitting duplicate elements.
Elements are compared using TEST, a function of two arguments.
 Elements match if TEST returns non-NIL.  Alternatively, specify TEST-NOT;
 then elements match if TEST-NOT returns NIL.
If KEY is non-NIL, then it is a function of one arg, which is applied
 to each element to get the \"key\" which is passed to TEST or TEST-NOT.
START and END are indices specifying the part of SUBSEQUENCE considered.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside this subsequence are not looked at.
Duplicate elements are not necessarily identical.
Normally the last duplicate element is the one retained.
If FROM-END is non-NIL, the first one is retained."
  (etypecase sequence
    (list (remove-duplicates-from-list sequence start end
				       test test-not key from-end))
    (vector (remove-duplicates-from-array sequence start end
					  test test-not key from-end))))


(defun delete-duplicates-from-list (list start end test test-not key from-end)
  (let* ((end-tail nil)
	 (tail-1 (if (zerop start)
		     (progn
		       (setq end-tail (and end (nthcdr end list)))
		       (if from-end
			 list			;first elt will always stay
			 (do (elt)
			     ((progn (setq elt (if key (funcall key (car list)) (car list)))
				     (not (sublist-member elt (cdr list) end-tail test test-not key)))
			      list)
			   (setq list (cdr list)))))			 
		     (nthcdr (1- start) list))))
    (when (and end (null end-tail))
      (setq end-tail (nthcdr (1+ (- end start)) tail-1)))
    (do (elt)
	((eq (cdr tail-1) end-tail))
      (setq elt (if key (funcall key (cadr tail-1)) (cadr tail-1)))
      (if (if from-end
	      (sublist-member elt list (cdr tail-1) test test-not key)
	    (sublist-member elt (cddr tail-1) end-tail test test-not key))
	(setf (cdr tail-1) (cddr tail-1))
	(setf tail-1 (cdr tail-1)))))
  list)

(defun delete-duplicates-from-array (vector start end test test-not key from-end)
  (remove-duplicates-from-array vector start end test test-not key from-end))

(defun substitute-in-list (new-item old-item list start end count test invertp key
			   from-end one-arg-predicate)
  (substitute-in-list-1 new-item old-item list start end count test invertp key one-arg-predicate
			(if (and from-end
				 count
				 (not (and end (>= count (- end start)))))
			    (max 0 (- (count-1 old-item list start end test invertp
					       key one-arg-predicate)
				      count))
			  0)))

(defun substitute-in-list-1 (new-item old-item list start end count test invertp key
			     one-arg-predicate skip-count)
  (let ((start-tail (if start (nthcdr start list) list)))
    (setq end (if end (nthcdr (- end start) start-tail) nil))
    (let ((new-head nil)
	  (new-pointer nil)
	  new)
      (do ((tail start-tail (cdr tail)))
	  ((eq tail end))
	(let ((item (if key (funcall key (car tail)) (car tail))))
	  (when (eq invertp (not (cond (one-arg-predicate
					(funcall one-arg-predicate old-item))
				       (test
					(funcall test old-item item))
				       (t
					(eql old-item item)))))
	    (if (plusp skip-count)
		(decf skip-count)
	      (if (if count
		      (when (plusp count)
			(decf count) t)
		    t)
		  (progn
		    ;; append from LIST to TAIL onto NEW-HEAD
		    (do ((l list (cdr l)))
			((eq l tail))
		      (setq new (cons (car l) nil))
		      (if new-head
			  (setf (cdr new-pointer) new)
			(setq new-head new))
		      (setq new-pointer new))
		    ;; append new item
		    (setq new (cons new-item nil))
		    (if new-head
			(setf (cdr new-pointer) new)
		      (setq new-head new))
		    (setq new-pointer new)
		    (setq list (cdr tail)))
		(return))))))
      (if new-head
	  (progn
	    (setf (cdr new-pointer) list)
	    new-head)
	list))))

(defun nsubstitute-in-list (new-item old-item list start end count test invertp key
			    from-end one-arg-predicate &aux (skip-count 0))
  (when (and from-end
	     count
             (not (and end (>= count (- end start)))))
      (setq skip-count (max 0 (- (count-1 old-item list start end test invertp
					  key one-arg-predicate)
				 count))))
  (let ((start-tail (if start (nthcdr start list) list)))
    (let ((end-tail (if end (nthcdr (- end start) start-tail) nil)))
     (do ((tail start-tail (cdr tail)))
	 ((eq tail end-tail))
       (let ((item (if key (funcall key (car tail)) (car tail))))
	 (when (eq invertp (not (cond (one-arg-predicate
				       (funcall one-arg-predicate old-item))
				      (test
				       (funcall test old-item item))
				      (t
				       (eql old-item item)))))
		(if (plusp skip-count)
		    (decf skip-count)
		  (if (if count
			    (when (plusp count)
			      (decf count) t)
			  t)
		      (setf (car tail) new-item)
		    (return))))))
	  list)))



(defun SUBSTITUTE (newitem olditem sequence
		   &key test test-not (start 0) end count key from-end)
  "Return SEQUENCE copied if necessary so that NEWITEM replaces any elements matching OLDITEM.
SEQUENCE can be a list or an array.  A list may be copied partially.
If COUNT is non-NIL, it is the number of such elements to replace.
The first COUNT-many suitable elements are replaced, or,
 if FROM-END is non-NIL, the last COUNT-many are replaced.
TEST is a function of two args to use to compare OLDITEM against an element (or key).
 An element matches when the TEST function returns non-NIL.
 Alternatively, specify as TEST-NOT a function to use which returns NIL if there is a match.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to TEST or TEST-NOT.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are never substituted for."
  (etypecase sequence
    (list (substitute-in-list newitem olditem sequence start end count (or test-not test) (not (null test-not))
	   key from-end nil))
    (vector (substitute-in-array t newitem olditem sequence start end count (or test-not test) (not (null test-not))
	   key from-end nil))))

(defun SUBSTITUTE-IF (newitem predicate sequence &key (start 0) end count key from-end)
  "Return SEQUENCE copied as necessary so that NEWITEM replaces any elements
satisfying PREDICATE.
SEQUENCE can be a list or an array.  A list may be copied partially.
If COUNT is non-NIL, it is the number of such elements to replace.
The first COUNT-many suitable elements are replaced, or,
 if FROM-END is non-NIL, the last COUNT-many are replaced.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to PREDICATE.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are never substituted for."
  (etypecase sequence
    (list (substitute-in-list newitem nil sequence start end count nil nil key from-end predicate))
    (vector (substitute-in-array t newitem nil sequence start end count nil nil key from-end predicate))))
	   

(defun SUBSTITUTE-IF-NOT (newitem predicate sequence &key (start 0) end count key from-end)
  "Like SUBSTITUTE-IF except the elements replaced are those for which PREDICATE returns NIL."
  (etypecase sequence
    (list (substitute-in-list newitem nil sequence start end count nil t key from-end predicate))
    (vector (substitute-in-array t newitem nil sequence start end count nil t key from-end predicate))))


(defun NSUBSTITUTE (newitem olditem sequence
		    &key test test-not (start 0) end count key from-end)
  "Like SUBSTITUTE except that SEQUENCE may be destructively modified rather than copied."
  (etypecase sequence
    (list (nsubstitute-in-list newitem olditem sequence start end count
			       (or test-not test) (not (null test-not)) key from-end nil))
    (vector (substitute-in-array nil newitem olditem sequence start end count
				 (or test-not test) (not (null test-not)) key from-end nil))))


(defun NSUBSTITUTE-IF (newitem predicate sequence &key (start 0) end count key from-end)
  "Like SUBSTITUTE-IF except that SEQUENCE may be destructively modified rather than copied."
  (etypecase sequence
    (list (nsubstitute-in-list newitem nil sequence start end count nil nil key from-end predicate))
    (vector (substitute-in-array nil newitem nil sequence start end count nil nil key from-end predicate))))

(defun NSUBSTITUTE-IF-NOT (newitem predicate sequence &key (start 0) end count key from-end)
  "Like SUBSTITUTE-IF-NOT except that SEQUENCE may be destructively modified
rather than copied."
  (etypecase sequence
    (list (nsubstitute-in-list newitem nil sequence start end count nil t key from-end predicate))
    (vector (substitute-in-array nil newitem nil sequence start end count nil t key from-end predicate))))

	   


;--------------------------------------------------------------------------------
;;;; Searching Sequences
;;;
;;; Brute Force Method, see SEQUENCES-BY-HAIR.LISP 
;;; for an example of the kind of trouble cleverness can cause.

;;;; COUNT

(defun COUNT (item sequence &key from-end test test-not (start 0) end key)
  "Return number of elements of SEQUENCE (a list or vector) that match ITEM.
TEST is a function of two args to use to compare ITEM against an element (or key).
 An element matches when the TEST function returns non-NIL.
 Alternatively, specify as TEST-NOT a function to use which returns NIL if there is a match.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to TEST or TEST-NOT.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are not counted."
  (count-1 item sequence start end key (or test test-not) (not (null test-not))  nil))

(defun COUNT-IF (test sequence &key from-end (start 0) end key)
  "Return number of elements of SEQUENCE (a list or array) that satisfy PREDICATE.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to PREDICATE.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are not counted."
  (count-1 nil sequence start end key nil nil test))

(defun COUNT-IF-NOT (test sequence &key from-end (start 0) end key)
  "Like COUNT-IF but counts elements that do NOT satisfy PREDICATE."
  (count-1 nil sequence start end key nil t test))

(defun count-1 (item sequence &optional (start 0) end key test invertp one-arg-predicate)
  (do ((index (seq-start sequence start))
       (count 0)
       (stop-index (seq-end sequence end))
       elt)
      ((eq index stop-index)
       count)
    (setq elt (key-fetch-inc key sequence index))
    (when (eq invertp (not (cond (one-arg-predicate
				  (funcall one-arg-predicate elt))
				 (test
				  (funcall test item elt))
				 (t
				  (eql item elt)))))
      (incf count))))


(defun count-eql (item sequence)
  (etypecase sequence
    (list (do ((tail sequence (cdr tail))
	       (count 0))
	      ((null tail)
	       count)
	    (when (eql (car tail) item)
	      (incf count))))
    (vector (do ((index 0 (1+ index))
		 (count 0)
		 (stop-index (length sequence)))
		((>= index stop-index)
		 count)
	      (when (eql (aref sequence index) item)
		(incf count))))))

(defun count-eq (item sequence)
  (etypecase sequence
    (list (do ((tail sequence (cdr tail))
	       (count 0))
	      ((null tail)
	       count)
	    (when (eq (car tail) item)
	      (incf count))))
    (vector (do ((index 0 (1+ index))
		 (count 0)
		 (stop-index (length sequence)))
		((>= index stop-index)
		 count)
	      (when (eq (aref sequence index) item)
		(incf count))))))

(defun count-if-nokey (test sequence)
  (do ((index (seq-start sequence nil))
       (count 0)
       (stop-index (seq-end sequence nil)))
      ((eq index stop-index)
       count)
    (when (funcall test (seq-fetch-inc sequence index))
      (incf count))))

(defun count-if-not-nokey (test sequence)
  (do ((index (seq-start sequence nil))
       (count 0)
       (stop-index (seq-end sequence nil)))
      ((eq index stop-index)
       count)
    (when (not (funcall test (seq-fetch-inc sequence index)))
      (incf count))))


(def-rewrite-patterns count (item sequence)
  (()                  `(COUNT-EQL ,item ,sequence))
  ((&key (test #'eq))  `(COUNT-EQ ,item ,sequence))
  ((&key start end)    `(COUNT-1 ,item ,sequence ,start ,end))
  ((&key from-end test start end key)
                       `(COUNT-1 ,item ,sequence ,start ,end ,key ,test)))


(def-rewrite-patterns count-if (test sequence)
  (() `(COUNT-IF-NOKEY ,test ,sequence)))

(def-rewrite-patterns count-if-not (test sequence)
  (() `(COUNT-IF-NOT-NOKEY ,test ,sequence)))

;--------------------------------------------------------------------------------
;;;; POSITION

(defun POSITION (item sequence &key from-end test test-not (start 0) end key)
  "Return index in SEQUENCE of first element that matches ITEM.
Value is NIL if no element matches.  SEQUENCE can be a list or an array.
TEST is a function of two args to use to compare ITEM against an element (or key).
 An element matches when the TEST function returns non-NIL.
 Alternatively, specify as TEST-NOT a function to use which returns NIL if there is a match.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to TEST or TEST-NOT.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are not tested.
 The value is the index in SEQUENCE, not in the subsequence which was searched.
If FROM-END is non-NIL, the value describes the LAST element in SEQUENCE
 (or specified subsequence) that matches."
  (position-1 item sequence start end from-end key (or test test-not) (not (null test-not))  nil))

(defun POSITION-IF (test sequence &key from-end (start 0) end key)
  "Return index in SEQUENCE of first element that satisfies PREDICATE.
Value is NIL if no element satisfies PREDICATE.  SEQUENCE can be a list or an array.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to PREDICATE.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are not tested.
 The value is the index in SEQUENCE, not in the subsequence which was searched.
If FROM-END is non-NIL, the value describes the LAST element in SEQUENCE
 (or specified subsequence) that satisfies the predicate."
  (position-1 nil sequence start end from-end key nil nil test))

(defun POSITION-IF-NOT (test sequence &key from-end (start 0) end key)
  "Like POSITION-IF but looks for an element which does NOT satisfy PREDICATE."
  (position-1 nil sequence start end from-end key nil t test))
  
(defun position-1 (item sequence &optional (start 0) end from-end key test invertp one-arg-predicate)
  (if (and from-end (arrayp sequence))
      (do ((index (1- (or end (length sequence))) (1- index))
	   elt)
	  ((< index start)
	   nil)
	(setq elt (if key (funcall key (aref sequence index))
		    (aref sequence index)))
	(when (eq invertp (not (cond (one-arg-predicate
				      (funcall one-arg-predicate elt))
				     (test
				      (funcall test item elt))
				     (t
				      (eql item elt)))))
	  (return index)))
      (do ((index (seq-start sequence start))
	   (i start (1+ i))
	   (stop-index (if (consp end) end (seq-end sequence end)))
	   last-pos elt)
	  ((eq index stop-index)
	   last-pos)
	(setq elt (key-fetch-inc key sequence index))
	(when (eq invertp (not (cond (one-arg-predicate
				      (funcall one-arg-predicate elt))
				     (test
				      (funcall test item elt))
				     (t
				      (eql item elt)))))
	  (if from-end
	      (setq last-pos i)
	    (return i))))))


(defun position-eql (item sequence)
  (etypecase sequence
    (list
     (do ((tail sequence (cdr tail))
	  (i 0 (1+ i)))
	 ((null tail))
       (when (eql (car tail) item)
	 (return i))))
    (vector
     (do ((i 0 (1+ i))
	  (stop-index (length sequence)))
	 ((>= i stop-index))
       (when (eql (aref sequence i) item)
	 (return i))))))

(defun position-eq (item sequence)
  (etypecase sequence
    (list
     (do ((tail sequence (cdr tail))
	  (i 0 (1+ i)))
	 ((null tail))
       (when (eq (car tail) item)
	 (return i))))
    (vector
     (do ((i 0 (1+ i))
	  (stop-index (length sequence)))
	 ((>= i stop-index))
       (when (eq (aref sequence i) item)
	 (return i))))))

(def-rewrite-patterns position (item sequence)
  (()                  `(POSITION-EQL ,item ,sequence))
  ((&key (test #'eq))  `(POSITION-EQ ,item ,sequence))
  ((&key start end)    `(POSITION-1 ,item ,sequence ,(or start 0) ,end))
  ((&key from-end start end key)
                       `(POSITION-1 ,item ,sequence ,(or start 0) ,end ,from-end ,key))
  ((&key from-end start end key test)
                       `(POSITION-1 ,item ,sequence ,(or start 0) ,end ,from-end ,key ,test))
  ((&key from-end start end key test-not)
                       `(POSITION-1 ,item ,sequence ,(or start 0) ,end ,from-end ,key ,test-not T)))

(def-rewrite-patterns position-if (test sequence)
  (()
   `(POSITION-1 NIL ,sequence 0 NIL NIL NIL NIL NIL ,test))
  ((&key from-end start end key)
   `(POSITION-1 NIL ,sequence ,(or start 0) ,end ,from-end ,key  NIL NIL ,test)))

(def-rewrite-patterns position-if-not (test sequence)
  (()
   `(POSITION-1 NIL ,sequence 0 NIL NIL NIL NIL T ,test))
  ((&key from-end start end key)
   `(POSITION-1 NIL ,sequence ,(or start 0) ,end ,from-end ,key  NIL T ,test)))


;--------------------------------------------------------------------------------
;;;; FIND

(defun FIND (item sequence &key from-end test test-not (start 0) end key)
  "Return first element of SEQUENCE that matches ITEM.
Value is NIL if no element matches.  SEQUENCE can be a list or an array.
TEST is a function of two args to use to compare ITEM against an element (or key).
 An element matches when the TEST function returns non-NIL.
 Alternatively, specify as TEST-NOT a function to use which returns NIL if there is a match.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to TEST or TEST-NOT.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are not tested.
If FROM-END is non-NIL, the value is the LAST element in SEQUENCE
 (or specified subsequence) that satisfies the predicate."
  (find-1 item sequence start end from-end key (or test test-not) (not (null test-not))  nil))

(defun FIND-IF (test sequence &key from-end start end key)
  "Return the first element of SEQUENCE that satisfies PREDICATE.
Value is NIL if no element satisfies PREDICATE.  SEQUENCE can be a list or an array.
KEY, if non-NIL, is a function to be applied to each element to get a key,
 which is passed to PREDICATE.  If KEY is NIL, the element itself is used.
START and END are indices restricting substitution to a subsequence of SEQUENCE.
 They default to 0 and NIL (which means the end of SEQUENCE).
 Elements outside that range are not tested.
If FROM-END is non-NIL, the value is the LAST element in SEQUENCE
 (or specified subsequence) that satisfies the predicate."
  (find-1 nil sequence start end from-end key nil nil test))

(defun FIND-IF-NOT (test sequence &key from-end start end key) 
  "Like FIND-IF but looks for an element which does NOT satisfy PREDICATE."
  (find-1 nil sequence start end from-end key nil t test))

(defun find-1 (item sequence &optional start end from-end key test invertp one-arg-predicate)
  (if (and from-end (arrayp sequence))
      (do ((index (1- (or end (length sequence))) (1- index))
	   elt)
	  ((< index start)
	   nil)
	(setq elt (if key (funcall key (aref sequence index))
		    (aref sequence index)))
	(when (eq invertp (not (cond (one-arg-predicate
				      (funcall one-arg-predicate elt))
				     (test
				      (funcall test item elt))
				     (t
				      (eql item elt)))))
	  (return (aref sequence index))))
      (do ((index (seq-start sequence start))
	   (i start (1+ i))
	   (stop-index (if (consp end) end (seq-end sequence end)))
	   last-pos elt)
	  ((eq index stop-index)
	   (if last-pos (elt sequence last-pos)))
	(setq elt (key-fetch-inc key sequence index))
	(when (eq invertp (not (cond (one-arg-predicate
				      (funcall one-arg-predicate elt))
				     (test
				      (funcall test item elt))
				     (t
				      (eql item elt)))))
	  (if from-end
	      (setq last-pos i)
	    (return elt))))))


(defun find-eql (item sequence)
  (etypecase sequence
    (list
     (do ((tail sequence (cdr tail)))
	 ((null tail))
       (when (eql (car tail) item)
	 (return (car tail)))))
    (vector
     (do ((i 0 (1+ i))
	  (stop-index (length sequence))
	  elt)
	 ((>= i stop-index))
       (setq elt (aref sequence i))
       (when (eql elt item)
	 (return elt))))))

(defun find-eq (item sequence)
  (etypecase sequence
    (list
     (do ((tail sequence (cdr tail)))
	 ((null tail))
       (when (eq (car tail) item)
	 (return (car tail)))))
    (vector
     (do ((i 0 (1+ i))
	  (stop-index (length sequence))
	  elt)
	 ((>= i stop-index))
       (setq elt (aref sequence i))
       (when (eq elt item)
	 (return elt))))))

(def-rewrite-patterns find (item sequence)
  (()                  `(FIND-EQL ,item ,sequence))
  ((&key (test #'eq))  `(FIND-EQ ,item ,sequence))
  ((&key start end)    `(FIND-1 ,item ,sequence ,start ,end))
  ((&key from-end start end key)
                       `(FIND-1 ,item ,sequence ,start ,end ,from-end ,key))
  ((&key from-end start end key test)
                       `(FIND-1 ,item ,sequence ,start ,end ,from-end ,key ,test nil))
  ((&key from-end start end key test-not)
                       `(FIND-1 ,item ,sequence ,start ,end ,from-end ,key ,test-not t)))

(def-rewrite-patterns find-if (test sequence)
  (()
   `(FIND-1 NIL ,sequence 0 NIL NIL NIL NIL NIL ,test))
  ((&key from-end start end key)
   `(FIND-1 NIL ,sequence ,start ,end ,from-end ,key  NIL NIL ,test)))

(def-rewrite-patterns find-if-not (test sequence)
  (()
   `(FIND-1 NIL ,sequence 0 NIL NIL NIL NIL T ,test))
  ((&key from-end start end key)
   `(FIND-1 NIL ,sequence ,start ,end ,from-end ,key  NIL T ,test)))


;--------------------------------------------------------------------------------
;;;; Sorting and Merging  




(defun MERGE (result-type sequence1 sequence2 predicate &key key)
  "Return a single sequence containing the elements of SEQUENCE1 and SEQUENCE2 interleaved.
The interleaving is done by taking the next element of SEQUENCE1 unless
the next element of SEQUENCE2 is \"less\" than it according to PREDICATE.
KEY, if non-NIL, is applied to each element to get the object to
pass to PREDICATE, rather than the element itself.
RESULT-TYPE specifies the type of sequence returned."
  (check-type sequence1 sequence)
  (check-type sequence2 sequence)
  (let* ((index-or-tail-1 (seq-start sequence1))
	(index-or-tail-2 (seq-start sequence2))
	(end1 (seq-end sequence1))
	(end2 (seq-end sequence2))
	(result-length (+ (length sequence1) (length sequence2)))
	(result (make-sequence result-type result-length)))
    (if (listp result)
	;; Changed to avoid compiler lossage 22sep88 Jim
	(merge-1-list result (cons sequence1 sequence2) predicate key (cons end1 end2) result-length
		      index-or-tail-1 index-or-tail-2)
      ;; Changed to avoid compiler lossage 22sep88 Jim
      (merge-1-vec result sequence1 sequence2 predicate key (cons end1 end2) result-length
		   index-or-tail-1 index-or-tail-2))))

;;; Changed to avoid compiler lossage 22sep88 Jim
(defun merge-1-vec (result sequence1 sequence2 predicate key end-stuff result-length
		    index-or-tail-1 index-or-tail-2)
  (do* ((store-index 0 (1+ store-index))
	e1 e2)
       ((= store-index result-length)
	result)
    (setf (aref result store-index)
	  (cond ((eq index-or-tail-1 (car end-stuff))
		 (seq-fetch-inc sequence2 index-or-tail-2))
		((eq index-or-tail-2 (cdr end-stuff))
		 (seq-fetch-inc sequence1 index-or-tail-1))
		(t
		 (setq e1 (seq-fetch sequence1 index-or-tail-1))
		 (setq e2 (seq-fetch sequence2 index-or-tail-2))
		 (cond ((apply-predicate-and-key predicate key e2 e1)
			(seq-inc index-or-tail-2) e2)
		       (t
			(seq-inc index-or-tail-1) e1)))))))

(defun merge-1-list (result sequences predicate key end-stuff result-length
		     index-or-tail-1 index-or-tail-2)
  (do* ((store-index 0 (1+ store-index))
	(temp result (cdr temp))
	e1 e2)
       ((= store-index result-length)
	result)
    (setf (car temp) (cond ((eq index-or-tail-1 (car end-stuff))
			    (seq-fetch-inc (cdr sequences) index-or-tail-2))
			   ((eq index-or-tail-2 (cdr end-stuff))
			    (seq-fetch-inc (car sequences) index-or-tail-1))
			   (t
			    (setq e1 (seq-fetch (car sequences) index-or-tail-1))
			    (setq e2 (seq-fetch (cdr sequences) index-or-tail-2))
			    (cond ((apply-predicate-and-key predicate key e2 e1)
				   (seq-inc index-or-tail-2) e2)
				  (t
				   (seq-inc index-or-tail-1) e1)))))))