| 1 | ;;;; SPLIT-SEQUENCE |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; This code was based on Arthur Lemmens' in |
|---|
| 4 | ;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>; |
|---|
| 5 | ;;; |
|---|
| 6 | |
|---|
| 7 | (in-package #:asdf-install) |
|---|
| 8 | |
|---|
| 9 | (defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied)) |
|---|
| 10 | "Return a list of subsequences in seq delimited by items satisfying |
|---|
| 11 | predicate. |
|---|
| 12 | |
|---|
| 13 | If :remove-empty-subseqs is NIL, empty subsequences will be included |
|---|
| 14 | in the result; otherwise they will be discarded. All other keywords |
|---|
| 15 | work analogously to those for CL:SUBSTITUTE-IF. In particular, the |
|---|
| 16 | behaviour of :from-end is possibly different from other versions of |
|---|
| 17 | this function; :from-end values of NIL and T are equivalent unless |
|---|
| 18 | :count is supplied. The second return value is an index suitable as an |
|---|
| 19 | argument to CL:SUBSEQ into the sequence indicating where processing |
|---|
| 20 | stopped." |
|---|
| 21 | (let ((len (length seq)) |
|---|
| 22 | (other-keys (when key-supplied |
|---|
| 23 | (list :key key)))) |
|---|
| 24 | (unless end (setq end len)) |
|---|
| 25 | (if from-end |
|---|
| 26 | (loop for right = end then left |
|---|
| 27 | for left = (max (or (apply #'position-if predicate seq |
|---|
| 28 | :end right |
|---|
| 29 | :from-end t |
|---|
| 30 | other-keys) |
|---|
| 31 | -1) |
|---|
| 32 | (1- start)) |
|---|
| 33 | unless (and (= right (1+ left)) |
|---|
| 34 | remove-empty-subseqs) ; empty subseq we don't want |
|---|
| 35 | if (and count (>= nr-elts count)) |
|---|
| 36 | ;; We can't take any more. Return now. |
|---|
| 37 | return (values (nreverse subseqs) right) |
|---|
| 38 | else |
|---|
| 39 | collect (subseq seq (1+ left) right) into subseqs |
|---|
| 40 | and sum 1 into nr-elts |
|---|
| 41 | until (< left start) |
|---|
| 42 | finally (return (values (nreverse subseqs) (1+ left)))) |
|---|
| 43 | (loop for left = start then (+ right 1) |
|---|
| 44 | for right = (min (or (apply #'position-if predicate seq |
|---|
| 45 | :start left |
|---|
| 46 | other-keys) |
|---|
| 47 | len) |
|---|
| 48 | end) |
|---|
| 49 | unless (and (= right left) |
|---|
| 50 | remove-empty-subseqs) ; empty subseq we don't want |
|---|
| 51 | if (and count (>= nr-elts count)) |
|---|
| 52 | ;; We can't take any more. Return now. |
|---|
| 53 | return (values subseqs left) |
|---|
| 54 | else |
|---|
| 55 | collect (subseq seq left right) into subseqs |
|---|
| 56 | and sum 1 into nr-elts |
|---|
| 57 | until (>= right end) |
|---|
| 58 | finally (return (values subseqs right)))))) |
|---|
| 59 | |
|---|