;;; Extensible sequences, based on the proposal by Christophe Rhodes.

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.

;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(cl:defpackage :sequence
  (:use)
  (:import-from :cl
                #:type-error-datum #:lambda #:&key #:&optional #:&rest
                #:&whole #:&body #:error #:null #:format #:class-of #:zerop
                #:multiple-value-bind #:cons #:cond #:and #:make-array
                #:array-element-type #:defvar #:defparameter
                #:make-list #:unless #:= #:let #:let* #:t #:make-array
                #:nil #:define-condition #:defun #:if #:eql
                #:setf #:defgeneric #:< #:rplacd #:nthcdr #:fill-pointer
                #:adjust-array #:declare #:ignore #:defmethod
                #:type-error #:apply #:array-total-size #:1- #:-
                #:array-has-fill-pointer-p #:>= #:or #:aref #:1+
                #:values #:car #:cdr #:cddr #:last #:not #:<=
                #:loop #:eq #:do* #:typecase #:gensym #:push
                #:mapcar #:defmacro #:fdefinition #:complement
                #:functionp #:flet #:list* #:funcall #:setq #:incf
                #:when #:do #:identity #:return #:floor #:ceiling #:+
                #:return-from #:> #:+ #:dotimes #:labels #:function
                #:ignorable #:prog1 #:minusp #:progn #:type #:the)
  (:export #:protocol-unimplemented #:protocol-unimplemented-operation
           #:merge #:with-sequence-iterator-functions #:make-sequence-like
           #:missing-arg #:emptyp #:length #:elt #:adjust-sequence
           #:make-sequence-iterator #:make-list-iterator #:make-vector-iterator
           #:make-simple-sequence-iterator #:iterator-step #:iterator-endp
           #:iterator-element #:iterator-index #:iterator-copy
           #:with-sequence-iterator #:find-if-not #:position #:position-if-not
           #:position-if #:subseq #:copy-seq #:fill #:nsubstitute
           #:nsubstitute-if #:nsubstitute-if-not #:substitute #:substitute-if
           #:substitute-if-not #:replace #:nreverse #:reverse #:concatenate
           #:reduce #:mismatch #:search #:delete #:delete-if #:delete-if-not
           #:remove #:remove-if #:remove-if-not #:delete-duplicates
           #:remove-duplicates #:sort #:stable-sort))
(uiop:define-package :gen-cl-user
    (:mix :sequence :cl))

(cl:in-package :sequence)

(defun missing-arg ()
  (error "A required &KEY or &OPTIONAL argument was not supplied."))


;;;; basic protocol
(define-condition protocol-unimplemented (type-error
                                          #+sbcl reference-condition)
  ((operation :initarg :operation
              :reader protocol-unimplemented-operation))
  (:default-initargs
   :operation (missing-arg)
    :references '((:sbcl :node "Extensible Sequences")))
  (:report
   (lambda (condition stream)
     (let ((operation (protocol-unimplemented-operation condition))
           (datum (type-error-datum condition)))
       (format stream "~@<The operation ~
                       ~/sb-ext:print-symbol-with-prefix/ is not ~
                       implemented for ~A which is an instance of the ~
                       ~/sb-ext:print-symbol-with-prefix/ subclass ~
                       ~S.~@:>"
               operation datum 'sequence (class-of datum)))))
  (:documentation
   "This error is signaled if a sequence operation is applied to an
   instance of a sequence class that does not support the
   operation."))

(defun protocol-unimplemented (operation sequence)
  (error 'protocol-unimplemented
         :datum sequence
         :expected-type '(or list vector)
         :operation operation))

(defgeneric emptyp (sequence)
  (:method ((s cl:list)) (null s))
  (:method ((s cl:vector)) (zerop (cl:length s)))
  (:method ((s cl:sequence)) (zerop (cl:length s)))
  (:documentation
   "Returns T if SEQUENCE is an empty sequence and NIL
   otherwise. Signals an error if SEQUENCE is not a sequence."))

(defgeneric length (sequence)
  (:method ((s cl:list)) (cl:length s))
  (:method ((s cl:vector)) (cl:length s))
  (:method ((s cl:sequence))
    (protocol-unimplemented 'length s))
  (:documentation
   "Returns the length of SEQUENCE or signals a PROTOCOL-UNIMPLEMENTED
   error if the sequence protocol is not implemented for the class of
   SEQUENCE."))

(defgeneric elt (sequence index)
  (:method ((s cl:list) index) (cl:elt s index))
  (:method ((s cl:vector) index) (cl:elt s index))
  (:method ((s cl:sequence) index)
    (cl:declare (cl:ignore index))
    (protocol-unimplemented 'elt s))
  (:documentation
   "Returns the element at position INDEX of SEQUENCE or signals a
   PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
   implemented for the class of SEQUENCE."))

(defgeneric (setf elt) (new-value sequence index)
  (:argument-precedence-order sequence new-value index)
  (:method (new-value (s cl:list) index) (setf (cl:elt s index) new-value))
  (:method (new-value (s cl:vector) index) (setf (cl:elt s index) new-value))
  (:method (new-value (s cl:sequence) index)
    (cl:declare (cl:ignore index new-value))
    (protocol-unimplemented '(setf elt) s))
  (:documentation
   "Replaces the element at position INDEX of SEQUENCE with NEW-VALUE
   and returns NEW-VALUE or signals a PROTOCOL-UNIMPLEMENTED error if
   the sequence protocol is not implemented for the class of
   SEQUENCE."))

(defgeneric make-sequence-like
    (sequence length &key initial-element initial-contents)
  (:method ((s cl:list) length
            &key (initial-element nil iep) (initial-contents nil icp))
    (cond
      ((and icp iep) (error "supplied both ~S and ~S to ~S"
                            :initial-element
                            :initial-contents
                            'make-sequence-like))
      (iep (make-list length :initial-element initial-element))
      (icp (unless (= (length initial-contents) length)
             (error "length mismatch in ~S" 'make-sequence-like))
           (let ((result (make-list length)))
             (replace result initial-contents)
             result))
      (t (make-list length))))
  (:method ((s cl:vector) length
            &key (initial-element nil iep) (initial-contents nil icp))
    (cond
      ((and icp iep) (error "supplied both ~S and ~S to ~S"
                            :initial-element
                            :initial-contents
                            'make-sequence-like))
      (iep (make-array length :element-type (array-element-type s)
                       :initial-element initial-element))
      (icp (make-array length :element-type (array-element-type s)
                       :initial-contents initial-contents))
      (t (make-array length :element-type (array-element-type s)))))
  (:method ((s cl:sequence) length &key initial-element initial-contents)
    (cl:declare (cl:ignore initial-element initial-contents length))
    (protocol-unimplemented 'make-sequence-like s))
  (:documentation
   "Returns a freshly allocated sequence of length LENGTH and of the
   same class as SEQUENCE. Elements of the new sequence are
   initialized to INITIAL-ELEMENT, if supplied, initialized to
   INITIAL-CONTENTS if supplied, or identical to the elements of
   SEQUENCE if neither is supplied. Signals a PROTOCOL-UNIMPLEMENTED
   error if the sequence protocol is not implemented for the class of
   SEQUENCE."))

(defgeneric adjust-sequence
    (sequence length &key initial-element initial-contents)
  (:method ((s cl:list) length &key initial-element (initial-contents nil icp))
    (if (eql length 0)
        nil
        (let ((olength (length s)))
          (cond
            ((eql length olength) (if icp (replace s initial-contents) s))
            ((< length olength)
             (rplacd (nthcdr (1- length) s) nil)
             (if icp (replace s initial-contents) s))
            ((null s)
             (let ((return (make-list length :initial-element initial-element)))
               (if icp (replace return initial-contents) return)))
            (t (rplacd (nthcdr (1- olength) s)
                       (make-list (- length olength)
                                  :initial-element initial-element))
               (if icp (replace s initial-contents) s))))))
  (:method ((s cl:vector) length
            &rest args &key (initial-contents nil icp) initial-element)
    (declare (ignore initial-element))
    (cond
      ((and (array-has-fill-pointer-p s)
            (>= (array-total-size s) length))
       (setf (fill-pointer s) length)
       (if icp (replace s initial-contents) s))
      ((eql (length s) length)
       (if icp (replace s initial-contents) s))
      (t (apply #'adjust-array s length args))))
  (:method ((s cl:sequence) length &rest args)
    (declare (ignore args length))
    (protocol-unimplemented 'adjust-sequence s))
  (:documentation
   "Return destructively modified SEQUENCE or a freshly allocated
   sequence of the same class as SEQUENCE of length LENGTH. Elements
   of the returned sequence are initialized to INITIAL-ELEMENT, if
   supplied, initialized to INITIAL-CONTENTS if supplied, or identical
   to the elements of SEQUENCE if neither is supplied. Signals a
   PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
   implemented for the class of SEQUENCE."))


;;;; iterator protocol

;;; The general protocol

(defgeneric make-sequence-iterator (sequence &key from-end start end)
  (:method ((s cl:vector) &key from-end (start 0) end)
    (make-vector-iterator s from-end start end))
  (:method ((s cl:list) &key from-end (start 0) end)
    (make-list-iterator s from-end start end))
  (:method ((s cl:sequence) &key from-end (start 0) end)
    (multiple-value-bind (iterator limit from-end)
        (make-simple-sequence-iterator
         s :from-end from-end :start start :end end)
      (values iterator limit from-end
              #'iterator-step #'iterator-endp
              #'iterator-element #'(setf iterator-element)
              #'iterator-index #'iterator-copy)))
  (:method ((s t) &key from-end start end)
    (declare (ignore from-end start end))
    (error 'type-error
           :datum s
           :expected-type 'sequence))
  (:documentation
   "Returns a sequence iterator for SEQUENCE or, if START and/or END
   are supplied, the subsequence bounded by START and END as nine
   values:

   1. iterator state
   2. limit
   3. from-end
   4. step function
   5. endp function
   6. element function
   7. setf element function
   8. index function
   9. copy state function

   If FROM-END is NIL, the constructed iterator visits the specified
   elements in the order in which they appear in SEQUENCE. Otherwise,
   the elements are visited in the opposite order."))

;;; magic termination value for list :from-end t
(defvar *exhausted* (cons nil nil))

(defun make-list-iterator (list from-end start end)
  (multiple-value-bind (iterator limit from-end)
      (if from-end
          (let* ((termination (if (= start 0) *exhausted* (nthcdr (1- start) list)))
                 (init (if (<= (or end (cl:length list)) start)
                           termination
                           (if end
                               (last list (- (cl:length list)
                                             (1- end)))
                               (last list)))))
            (values init termination t))
          (cond
            ((not end) (values (nthcdr start list) nil nil))
            (t (let ((st (nthcdr start list)))
                 (values st (nthcdr (- end start) st) nil)))))
    (values iterator limit from-end
            (if from-end
                (lambda (list iterator from-end)
                  (declare (ignore from-end))
                  (if (eq iterator list)
                      *exhausted*
                      (do* ((cdr list (cdr cdr)))
                           ((eq (cdr cdr) iterator) cdr)))
                  (1+ iterator))
                (lambda (list iterator from-end)
                  (declare (ignore list from-end))
                  (cdr iterator)))
            (lambda (list iterator limit from-end)
              (declare (ignore list from-end))
              (eq iterator limit))
            (lambda (list iterator)
              (declare (ignore list))
              (car iterator))
            (lambda (new-value list iterator)
              (declare (ignore list))
              (setf (car iterator) new-value))
            (lambda (list iterator)
              (loop for cdr on list
                 for i from 0
                 when (eq cdr iterator)
                 return i))
            (lambda (list iterator)
              (declare (ignore list))
              iterator))))

(defun make-vector-iterator (vector from-end start end)
  (let* ((end (or end (length vector)))
         (iterator (if from-end
                       (1- end)
                       start))
         (limit (if from-end
                    (1- start)
                    end)))
    (values iterator limit from-end
            (if from-end
                (lambda (sequence iterator from-end)
                  (declare (ignore sequence from-end))
                  (1- iterator))
                (lambda (sequence iterator from-end)
                  (declare (ignore sequence from-end))
                  (1+ iterator)))
            (lambda (sequence iterator limit from-end)
              (declare (ignore sequence from-end))
              (= iterator limit))
            (lambda (sequence iterator)
              (aref sequence iterator))
            (lambda (new-value sequence iterator)
              (setf (aref sequence iterator) new-value))
            (lambda (sequence iterator)
              (declare (ignore sequence))
              iterator)
            (lambda (sequence iterator)
              (declare (ignore sequence))
              iterator))))

;;; the simple protocol: the simple iterator returns three values,
;;; STATE, LIMIT and FROM-END.
(defgeneric make-simple-sequence-iterator
    (sequence &key from-end start end)
  (:method ((s cl:list) &key from-end (start 0) end)
    (if from-end
        (let* ((termination (if (= start 0) *exhausted* (nthcdr (1- start) s)))
               (init (if (<= (or end (length s)) start)
                         termination
                         (if end (last s (- (length s) (1- end))) (last s)))))
          (values init termination t))
        (cond
          ((not end) (values (nthcdr start s) nil nil))
          (t (let ((st (nthcdr start s)))
               (values st (nthcdr (- end start) st) nil))))))
  (:method ((s cl:vector) &key from-end (start 0) end)
    (let ((end (or end (length s))))
      (if from-end
          (values (1- end) (1- start) t)
          (values start end nil))))
  (:method ((s cl:sequence) &key from-end (start 0) end)
    (let ((end (or end (length s))))
      (if from-end
          (values (1- end) (1- start) from-end)
          (values start end nil))))
  (:documentation
   "Returns a sequence iterator for SEQUENCE, START, END and FROM-END
   as three values:

   1. iterator state
   2. limit
   3. from-end

   The returned iterator can be used with the generic iterator
   functions ITERATOR-STEP, ITERATOR-ENDP, ITERATOR-ELEMENT, (SETF
   ITERATOR-ELEMENT), ITERATOR-INDEX and ITERATOR-COPY."))

(defgeneric iterator-step (sequence iterator from-end)
  (:method ((s cl:list) iterator from-end)
    (if from-end
        (if (eq iterator s)
            *exhausted*
            (do* ((xs s (cdr xs)))
                 ((eq (cdr xs) iterator) xs)))
        (cdr iterator)))
  (:method ((s cl:vector) iterator from-end)
    (if from-end
        (1- iterator)
        (1+ iterator)))
  (:method ((s cl:sequence) iterator from-end)
    (if from-end
        (1- iterator)
        (1+ iterator)))
  (:documentation
   "Moves ITERATOR one position forward or backward in SEQUENCE
   depending on the iteration direction encoded in FROM-END."))

(defgeneric iterator-endp (sequence iterator limit from-end)
  (:method ((s cl:list) iterator limit from-end)
    (declare (ignore from-end))
    (eq iterator limit))
  (:method ((s cl:vector) iterator limit from-end)
    (declare (ignore from-end))
    (= iterator limit))
  (:method ((s cl:sequence) iterator limit from-end)
    (declare (ignore from-end))
    (= iterator limit))
  (:documentation
   "Returns non-NIL when ITERATOR has reached LIMIT (which may
   correspond to the end of SEQUENCE) with respect to the iteration
   direction encoded in FROM-END."))

(defgeneric iterator-element (sequence iterator)
  (:method ((s cl:list) iterator)
    (car iterator))
  (:method ((s cl:vector) iterator)
    (aref s iterator))
  (:method ((s cl:sequence) iterator)
    (elt s iterator))
  (:documentation
   "Returns the element of SEQUENCE associated to the position of
   ITERATOR."))

(defgeneric (setf iterator-element) (new-value sequence iterator)
  (:method (o (s cl:list) iterator)
    (setf (car iterator) o))
  (:method (o (s cl:vector) iterator)
    (setf (aref s iterator) o))
  (:method (o (s cl:sequence) iterator)
    (setf (elt s iterator) o))
  (:documentation
   "Destructively modifies SEQUENCE by replacing the sequence element
   associated to position of ITERATOR with NEW-VALUE."))

(defgeneric iterator-index (sequence iterator)
  (:method ((s cl:list) iterator)
    ;; FIXME: this sucks.  (In my defence, it is the equivalent of the
    ;; Apple implementation in Dylan...)
    (loop for l on s for i from 0 when (eq l iterator) return i))
  (:method ((s cl:vector) iterator) iterator)
  (:method ((s cl:sequence) iterator) iterator)
  (:documentation
   "Returns the position of ITERATOR in SEQUENCE."))

(defgeneric iterator-copy (sequence iterator)
  (:method ((s cl:list) iterator) iterator)
  (:method ((s cl:vector) iterator) iterator)
  (:method ((s cl:sequence) iterator) iterator)
  (:documentation
   "Returns a copy of ITERATOR which also traverses SEQUENCE but can
   be mutated independently of ITERATOR."))

(defun %make-sequence-iterator (sequence from-end start end)
  (typecase sequence
    (cl:vector
     (make-vector-iterator sequence from-end start end))
    (cl:list
     (make-list-iterator sequence from-end start end))
    (t
     (make-sequence-iterator sequence
                             :end end
                             :start start
                             :from-end from-end))))

(defmacro with-sequence-iterator
    ((&whole vars
             &optional iterator limit from-end-p
             step endp element set-element index copy)
               (sequence &key from-end (start 0) end) &body body)
  "Executes BODY with the elements of VARS bound to the iteration
  state returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE and
  ARGS. Elements of VARS may be NIL in which case the corresponding
  value returned by MAKE-SEQUENCE-ITERATOR is ignored."
  (declare (ignore iterator limit from-end-p
                   step endp element set-element index copy))
  (let* ((ignored '())
         (vars (mapcar (lambda (x)
                         (or x (let ((name (gensym)))
                                 (push name ignored)
                                 name)))
                       vars)))
    `(multiple-value-bind (,@vars)
         (%make-sequence-iterator ,sequence ,from-end ,start ,end)
       (declare (cl:type function ,@(nthcdr 3 vars))
                (ignore ,@ignored))
       ,@body)))

(defmacro with-sequence-iterator-functions
    ((step endp elt setf index copy)
     (sequence &rest args &key from-end start end)
     &body body)
  "Executes BODY with the names STEP, ENDP, ELT, SETF, INDEX and COPY
  bound to local functions which execute the iteration state query and
  mutation functions returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE
  and ARGS. STEP, ENDP, ELT, SETF, INDEX and COPY have dynamic
  extent."
  (declare (ignore from-end start end))
  (let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
        (nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
        (nendp (gensym "ENDP")) (nelt (gensym "ELT"))
        (nsetf (gensym "SETF")) (nindex (gensym "INDEX"))
        (ncopy (gensym "COPY")))
    `(with-sequence-iterator
         (,nstate ,nlimit ,nfrom-end ,nstep ,nendp ,nelt ,nsetf ,nindex ,ncopy)
         (,sequence,@args)
       (declare (cl:ignorable ,nstate ,nlimit ,nfrom-end ,nstep ,nendp ,nelt ,nsetf ,nindex ,ncopy))
       (flet ((,step () (setq ,nstate (funcall ,nstep ,sequence,nstate ,nfrom-end)))
              (,endp () (funcall ,nendp ,sequence,nstate ,nlimit ,nfrom-end))
              (,elt () (funcall ,nelt ,sequence,nstate))
              (,setf (new-value) (funcall ,nsetf new-value ,sequence,nstate))
              (,index () (funcall ,nindex ,sequence,nstate))
              (,copy () (funcall ,ncopy ,sequence,nstate)))
         (declare (cl:dynamic-extent #',step #',endp #',elt
                                     #',setf #',index #',copy))
         ,@body))))

(defmacro define-shadowing-generic (name (&rest args) &body options)
  (let* ((seq-position (cl:position 'sequence args))
         (pre-args (cl:subseq args 0 seq-position))
         (raw-post-args (cl:subseq args (1+ seq-position)))
         (cl-name (cl:intern (cl:symbol-name name) :cl))
         (tail (cl:member #\& raw-post-args
                          :key (lambda (x)
                                 (cl:elt (cl:symbol-name x)
                                         0))))
         (post-args (if (and tail (not (eql (car tail) '&optional)))
                        `(,@(loop for x in raw-post-args
                               for rest on raw-post-args
                               while (not (eq rest tail))
                               collect x)
                            &rest r)
                        raw-post-args)))
    (unless seq-position
      (error "no sequence argument"))
    `(defgeneric ,name ,args
       (:method (,@pre-args (sequence cl:sequence) ,@post-args)
         (declare (cl:inline))
         (apply #',cl-name ,@pre-args sequence
                ,@(cl:remove #\& post-args
                             :key (lambda (x)
                                    (cl:elt (cl:symbol-name x)
                                            0)))))
       ,@options)))

(define-shadowing-generic find-if-not
    (pred sequence &key from-end start end key)
  (:argument-precedence-order sequence pred))

(define-shadowing-generic position
    (item sequence &key from-end start end test test-not key)
  (:argument-precedence-order sequence item))


(define-shadowing-generic position-if (pred sequence &key from-end start end key)
  (:argument-precedence-order sequence pred))


(define-shadowing-generic position-if-not
    (pred sequence &key from-end start end key)
  (:argument-precedence-order sequence pred))


(define-shadowing-generic subseq (sequence start &optional end))


(define-shadowing-generic copy-seq (sequence))


(define-shadowing-generic fill (sequence item &key start end))


(define-shadowing-generic nsubstitute
    (new old sequence &key start end from-end test test-not count key)
  (:argument-precedence-order sequence new old))


(define-shadowing-generic nsubstitute-if
    (new predicate sequence &key start end from-end count key)
  (:argument-precedence-order sequence new predicate))


(define-shadowing-generic nsubstitute-if-not
    (new predicate sequence &key start end from-end count key)
  (:argument-precedence-order sequence new predicate))


(define-shadowing-generic substitute
    (new old sequence &key start end from-end test test-not count key)
  (:argument-precedence-order sequence new old))


(define-shadowing-generic substitute-if
    (new predicate sequence &key start end from-end count key)
  (:argument-precedence-order sequence new predicate))


(define-shadowing-generic substitute-if-not
    (new predicate sequence &key start end from-end count key)
  (:argument-precedence-order sequence new predicate))


(defun %sequence-replace (sequence1 sequence2 start1 end1 start2 end2)
  (with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1 setelt1)
      (sequence1 :start start1 :end end1)
    (declare (ignore elt1))
    (with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
        (sequence2 :start start2 :end end2)
      (do ()
          ((or (funcall endp1 sequence1 state1 limit1 from-end1)
               (funcall endp2 sequence2 state2 limit2 from-end2))
           sequence1)
        (funcall setelt1 (funcall elt2 sequence2 state2) sequence1 state1)
        (setq state1 (funcall step1 sequence1 state1 from-end1))
        (setq state2 (funcall step2 sequence2 state2 from-end2))))))

(defgeneric replace
    (sequence1 sequence2 &key start1 end1 start2 end2)
  (:argument-precedence-order sequence2 sequence1))


(define-shadowing-generic nreverse (sequence))


(define-shadowing-generic reverse (sequence))


(defgeneric concatenate (result-prototype &rest sequences)
  (:documentation
   "Implements CL:CONCATENATE for extended sequences.

    RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:CONCATENATE
    but receives a prototype instance of an extended sequence class
    instead of a type specifier. By dispatching on RESULT-PROTOTYPE,
    methods on this generic function specify how extended sequence
    classes act when they are specified as the result type in a
    CL:CONCATENATE call. RESULT-PROTOTYPE may not be fully initialized
    and thus should only be used for dispatch and to determine its
    class."))



(define-shadowing-generic reduce
    (function sequence &key from-end start end initial-value)
  (:argument-precedence-order sequence function))


(defgeneric mismatch (sequence1 sequence2 &key from-end start1 end1
                                            start2 end2 test test-not key))


(defgeneric search (sequence1 sequence2 &key from-end start1 end1
                                          start2 end2 test test-not key))


(define-shadowing-generic delete
    (item sequence &key from-end test test-not start end count key)
  (:argument-precedence-order sequence item))


(define-shadowing-generic delete-if
    (predicate sequence &key from-end start end count key)
  (:argument-precedence-order sequence predicate))


(define-shadowing-generic delete-if-not
    (predicate sequence &key from-end start end count key)
  (:argument-precedence-order sequence predicate))


(define-shadowing-generic remove
    (item sequence &key from-end test test-not start end count key)
  (:argument-precedence-order sequence item))


(define-shadowing-generic remove-if
    (predicate sequence &key from-end start end count key)
  (:argument-precedence-order sequence predicate))


(define-shadowing-generic remove-if-not
    (predicate sequence &key from-end start end count key)
  (:argument-precedence-order sequence predicate))


(define-shadowing-generic delete-duplicates
    (sequence &key from-end test test-not start end key))


(define-shadowing-generic remove-duplicates
    (sequence &key from-end test test-not start end key))

(define-shadowing-generic sort (sequence predicate &key key))


(define-shadowing-generic stable-sort (sequence predicate &key key))


(defgeneric merge (result-prototype sequence1 sequence2 predicate &key key)
  (:documentation
   "Implements CL:MERGE for extended sequences.

    RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:MERGE but
    receives a prototype instance of an extended sequence class
    instead of a type specifier. By dispatching on RESULT-PROTOTYPE,
    methods on this generic function specify how extended sequence
    classes act when they are specified as the result type in a
    CL:MERGE call. RESULT-PROTOTYPE may not be fully initialized and
    thus should only be used for dispatch and to determine its class.

    Another difference to CL:MERGE is that PREDICATE is a function,
    not a function designator."))

(defun %coerce-callable-to-fun (callable)
  (cl:etypecase callable
    (function callable)
    (cl:symbol (cl:symbol-function callable))))

(defmethod sequence:merge ((result-prototype cl:sequence) (sequence1 cl:sequence) (sequence2 cl:sequence)
                           (predicate cl:function) &key key)
  (let ((key-function (when key
                        (%coerce-callable-to-fun key)))
        (result (sequence:make-sequence-like
                 result-prototype (+ (length sequence1) (length sequence2))))
        endp1 elt1 key1 endp2 elt2 key2)
    (sequence:with-sequence-iterator-functions
        (step-result endp-result elt-result setelt-result index-result copy-result) (result)
      ;; TODO allow nil and fewer number of elements
      (declare (ignorable #'endp-result #'elt-result #'copy-result))
      (sequence:with-sequence-iterator-functions
          (step1 endp1 elt1 setelt1 index1 copy1) (sequence1)
        (declare (ignorable #'setelt1 #'copy1))
        (sequence:with-sequence-iterator-functions
            (step2 endp2 elt2 setelt2 index2 copy2) (sequence2)
          (declare (ignorable #'setelt2 #'copy2))
          (labels ((pop/no-key1 ()
                     (unless (setf endp1 (endp1))
                       (setf elt1 (elt1))))
                   (pop/no-key2 ()
                     (unless (setf endp2 (endp2))
                       (setf elt2 (elt2))))
                   (pop/key1 ()
                     (unless (setf endp1 (endp1))
                       (setf key1 (funcall (the function key-function)
                                           (setf elt1 (elt1))))))
                   (pop/key2 ()
                     (unless (setf endp2 (endp2))
                       (setf key2 (funcall (the function key-function)
                                           (setf elt2 (elt2))))))
                   (pop-one/no-key ()
                     (if (funcall predicate elt2 elt1) ; see comment in MERGE-LIST*
                         (prog1 elt2 (step2) (pop/no-key2))
                         (prog1 elt1 (step1) (pop/no-key1))))
                   (pop-one/key ()
                     (if (funcall predicate key2 key1)
                         (prog1 elt2 (step2) (pop/key2))
                         (prog1 elt1 (step1) (pop/key1)))))
            (declare (cl:dynamic-extent #'pop/no-key1 #'pop/no-key2
                                        #'pop/key1 #'pop/key2
                                        #'pop-one/no-key #'pop-one/key))
            ;; Populate ENDP{1,2}, ELT{1,2} and maybe KEY{1,2}.
            (cond (key-function (pop/key1) (pop/key2))
                  (t (pop/no-key1) (pop/no-key2)))
            (loop with pop-one = (if key-function #'pop-one/key #'pop-one/no-key) do
                 (cond
                   (endp2 ; batch-replace rest of SEQUENCE1 if SEQUENCE2 exhausted
                    (unless endp1
                      (replace result sequence1 :start1 (index-result) :start2 (index1)))
                    (return))
                   (endp1
                    (unless endp2
                      (replace result sequence2 :start1 (index-result) :start2 (index2)))
                    (return))
                   (t
                    (setelt-result (funcall pop-one))
                    (step-result))))))))
    result))