Mercurial > core / lisp/std/seq.lisp

 ;;; std/seq.lisp --- Standard Sequences
 
 ;;
 
 ;;; Code:
 (in-package :std/seq)
 
 ;; from serapeum
 (declaim (inline firstn))
 (defun firstn (n list)
   (loop repeat n for x in list collect x))
 
 (defun take (n seq)
   "Return, at most, the first N elements of SEQ, as a *new* sequence
 of the same type as SEQ.
 
 If N is longer than SEQ, SEQ is simply copied.
 
 If N is negative, then |N| elements are taken (in their original
 order) from the end of SEQ."
   (declare (type signed-array-length n))
   (sb-impl::seq-dispatch seq
     (if (minusp n)
         (last seq (abs n))
         (firstn n seq))
     (if (minusp n)
         (subseq seq (max 0 (+ (length seq) n)))
         (subseq seq 0 (min n (length seq))))))
 
 (defun starts-with-subseq (prefix sequence &rest args
                            &key
                            return-suffix
                            &allow-other-keys)
   "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
 
 If RETURN-SUFFIX is T the function returns, as a second value, a
 sub-sequence or displaced array pointing to the sequence after PREFIX."
   (declare (dynamic-extent args))
   (let ((sequence-length (length sequence))
         (prefix-length (length prefix)))
     (when (< sequence-length prefix-length)
       (return-from starts-with-subseq (values nil nil)))
     (flet ((make-suffix (start)
              (when return-suffix
                (cond
                  ((not (arrayp sequence))
                   (if start
                       (subseq sequence start)
                       (subseq sequence 0 0)))
                  ((not start)
                   (make-array 0
                               :element-type (array-element-type sequence)
                               :adjustable nil))
                  (t
                   (make-array (- sequence-length start)
                               :element-type (array-element-type sequence)
                               :displaced-to sequence
                               :displaced-index-offset start
                               :adjustable nil))))))
       (remf args :return-suffix)
       (let ((mismatch (apply #'mismatch prefix sequence
                              args)))
         (cond
           ((not mismatch)
            (values t (make-suffix nil)))
           ((= mismatch prefix-length)
            (values t (make-suffix mismatch)))
           (t
            (values nil nil)))))))
 
 (defun ends-with-subseq (suffix sequence &key (test #'eql))
   "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
 the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
   (let ((sequence-length (length sequence))
         (suffix-length (length suffix)))
     (when (< sequence-length suffix-length)
       ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end with SUFFIX.
       (return-from ends-with-subseq nil))
     (loop for sequence-index from (- sequence-length suffix-length) below sequence-length
           for suffix-index from 0 below suffix-length
           when (not (funcall test (elt sequence sequence-index) (elt suffix suffix-index)))
           do (return-from ends-with-subseq nil)
           finally (return t))))
 
 (defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
   "Return a list of subsequences in seq delimited by delimiter.
 
 If :remove-empty-subseqs is NIL, empty subsequences will be included
 in the result; otherwise they will be discarded.  All other keywords
 work analogously to those for CL:SUBSTITUTE.  In particular, the
 behaviour of :from-end is possibly different from other versions of
 this function; :from-end values of NIL and T are equivalent unless
 :count is supplied. The second return value is an index suitable as an
 argument to CL:SUBSEQ into the sequence indicating where processing
 stopped."
   (let ((len (length seq))
         (other-keys (nconc (when test-supplied 
                              (list :test test))
                            (when test-not-supplied 
                              (list :test-not test-not))
                            (when key-supplied 
                              (list :key key)))))
     (unless end (setq end len))
     (if from-end
         (loop for right = end then left
               for left = (max (or (apply #'position delimiter seq 
                                          :end right
                                          :from-end t
                                          other-keys)
                                   -1)
                               (1- start))
               unless (and (= right (1+ left))
                           remove-empty-subseqs) ; empty subseq we don't want
               if (and count (>= nr-elts count))
               ;; We can't take any more. Return now.
               return (values (nreverse subseqs) right)
               else 
               collect (subseq seq (1+ left) right) into subseqs
               and sum 1 into nr-elts
               until (< left start)
               finally (return (values (nreverse subseqs) (1+ left))))
       (loop for left = start then (+ right 1)
             for right = (min (or (apply #'position delimiter seq 
                                         :start left
                                         other-keys)
                                  len)
                              end)
             unless (and (= right left) 
                         remove-empty-subseqs) ; empty subseq we don't want
             if (and count (>= nr-elts count))
             ;; We can't take any more. Return now.
             return (values subseqs left)
             else
             collect (subseq seq left right) into subseqs
             and sum 1 into nr-elts
             until (>= right end)
             finally (return (values subseqs right))))))
 
 (defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
   "Return a list of subsequences in seq delimited by items satisfying
 predicate.
 
 If :remove-empty-subseqs is NIL, empty subsequences will be included
 in the result; otherwise they will be discarded.  All other keywords
 work analogously to those for CL:SUBSTITUTE-IF.  In particular, the
 behaviour of :from-end is possibly different from other versions of
 this function; :from-end values of NIL and T are equivalent unless
 :count is supplied. The second return value is an index suitable as an
 argument to CL:SUBSEQ into the sequence indicating where processing
 stopped."
   (let ((len (length seq))
         (other-keys (when key-supplied 
                       (list :key key))))
     (unless end (setq end len))
     (if from-end
         (loop for right = end then left
               for left = (max (or (apply #'position-if predicate seq 
                                          :end right
                                          :from-end t
                                          other-keys)
                                   -1)
                               (1- start))
               unless (and (= right (1+ left))
                           remove-empty-subseqs) ; empty subseq we don't want
               if (and count (>= nr-elts count))
               ;; We can't take any more. Return now.
               return (values (nreverse subseqs) right)
               else 
               collect (subseq seq (1+ left) right) into subseqs
               and sum 1 into nr-elts
               until (< left start)
               finally (return (values (nreverse subseqs) (1+ left))))
       (loop for left = start then (+ right 1)
             for right = (min (or (apply #'position-if predicate seq 
                                         :start left
                                         other-keys)
                                  len)
                              end)
             unless (and (= right left) 
                         remove-empty-subseqs) ; empty subseq we don't want
             if (and count (>= nr-elts count))
             ;; We can't take any more. Return now.
             return (values subseqs left)
             else
             collect (subseq seq left right) into subseqs
             and sum 1 into nr-elts
             until (>= right end)
             finally (return (values subseqs right))))))
 
 (defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
   "Return a list of subsequences in seq delimited by items satisfying
 (CL:COMPLEMENT predicate).
 
 If :remove-empty-subseqs is NIL, empty subsequences will be included
 in the result; otherwise they will be discarded.  All other keywords
 work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
 the behaviour of :from-end is possibly different from other versions
 of this function; :from-end values of NIL and T are equivalent unless
 :count is supplied. The second return value is an index suitable as an
 argument to CL:SUBSEQ into the sequence indicating where processing
 stopped."				; Emacs syntax highlighting is broken, and this helps: "
   (let ((len (length seq))
         (other-keys (when key-supplied 
                       (list :key key))))
     (unless end (setq end len))
     (if from-end
         (loop for right = end then left
               for left = (max (or (apply #'position-if-not predicate seq 
                                          :end right
                                          :from-end t
                                          other-keys)
                                   -1)
                               (1- start))
               unless (and (= right (1+ left))
                           remove-empty-subseqs) ; empty subseq we don't want
               if (and count (>= nr-elts count))
               ;; We can't take any more. Return now.
               return (values (nreverse subseqs) right)
               else 
               collect (subseq seq (1+ left) right) into subseqs
               and sum 1 into nr-elts
               until (< left start)
               finally (return (values (nreverse subseqs) (1+ left))))
       (loop for left = start then (+ right 1)
             for right = (min (or (apply #'position-if-not predicate seq 
                                         :start left
                                         other-keys)
                                  len)
                              end)
             unless (and (= right left) 
                         remove-empty-subseqs) ; empty subseq we don't want
             if (and count (>= nr-elts count))
             ;; We can't take any more. Return now.
             return (values subseqs left)
             else
             collect (subseq seq left right) into subseqs
             and sum 1 into nr-elts
             until (>= right end)
             finally (return (values subseqs right))))))