tsplit-sequence.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tsplit-sequence.lisp (8164B)
---
1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; SPLIT-SEQUENCE
4 ;;;
5 ;;; This code was based on Arthur Lemmens' in
6 ;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
7 ;;;
8 ;;; changes include:
9 ;;;
10 ;;; * altering the behaviour of the :from-end keyword argument to
11 ;;; return the subsequences in original order, for consistency with
12 ;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
13 ;;; affects the answer if :count is less than the number of
14 ;;; subsequences, by analogy with the above-referenced functions).
15 ;;;
16 ;;; * changing the :maximum keyword argument to :count, by analogy
17 ;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
18 ;;;
19 ;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
20 ;;; than SPLIT.
21 ;;;
22 ;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
23 ;;;
24 ;;; * The second return value is now an index rather than a copy of a
25 ;;; portion of the sequence; this index is the `right' one to feed to
26 ;;; CL:SUBSEQ for continued processing.
27
28 ;;; There's a certain amount of code duplication here, which is kept
29 ;;; to illustrate the relationship between the SPLIT-SEQUENCE
30 ;;; functions and the CL:POSITION functions.
31
32 (defpackage :split-sequence
33 (:use :common-lisp)
34 (:export #:split-sequence
35 #:split-sequence-if
36 #:split-sequence-if-not))
37
38 (in-package :split-sequence)
39
40 (deftype array-index (&optional (length array-dimension-limit))
41 `(integer 0 (,length)))
42
43 (declaim (ftype (function (&rest t) (values list integer))
44 split-sequence split-sequence-if split-sequence-if-not))
45
46 (declaim (ftype (function (function sequence array-index
47 (or null array-index) (or null array-index) boolean)
48 (values list integer))
49 split-from-start split-from-end))
50
51 (macrolet ((check-bounds (sequence start end)
52 (let ((length (gensym (string '#:length))))
53 `(let ((,length (length ,sequence)))
54 (check-type ,start unsigned-byte "a non-negative integer")
55 (when ,end (check-type ,end unsigned-byte "a non-negative integer or NIL"))
56 (unless ,end
57 (setf ,end ,length))
58 (unless (<= ,start ,end ,length)
59 (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end))))))
60
61 (defun split-sequence (delimiter sequence &key (start 0) (end nil) (from-end nil)
62 (count nil) (remove-empty-subseqs nil)
63 (test #'eql) (test-not nil) (key #'identity))
64 "Return a list of subsequences in seq delimited by delimiter.
65
66 If :remove-empty-subseqs is NIL, empty subsequences will be included
67 in the result; otherwise they will be discarded. All other keywords
68 work analogously to those for CL:SUBSTITUTE. In particular, the
69 behaviour of :from-end is possibly different from other versions of
70 this function; :from-end values of NIL and T are equivalent unless
71 :count is supplied. The second return value is an index suitable as an
72 argument to CL:SUBSEQ into the sequence indicating where processing
73 stopped."
74 (check-bounds sequence start end)
75 (cond
76 ((and (not from-end) (null test-not))
77 (split-from-start (lambda (sequence start)
78 (position delimiter sequence :start start :key key :test test))
79 sequence start end count remove-empty-subseqs))
80 ((and (not from-end) test-not)
81 (split-from-start (lambda (sequence start)
82 (position delimiter sequence :start start :key key :test-not test-not))
83 sequence start end count remove-empty-subseqs))
84 ((and from-end (null test-not))
85 (split-from-end (lambda (sequence end)
86 (position delimiter sequence :end end :from-end t :key key :test test))
87 sequence start end count remove-empty-subseqs))
88 (t
89 (split-from-end (lambda (sequence end)
90 (position delimiter sequence :end end :from-end t :key key :test-not test-not))
91 sequence start end count remove-empty-subseqs))))
92
93 (defun split-sequence-if (predicate sequence &key (start 0) (end nil) (from-end nil)
94 (count nil) (remove-empty-subseqs nil) (key #'identity))
95 "Return a list of subsequences in seq delimited by items satisfying
96 predicate.
97
98 If :remove-empty-subseqs is NIL, empty subsequences will be included
99 in the result; otherwise they will be discarded. All other keywords
100 work analogously to those for CL:SUBSTITUTE-IF. In particular, the
101 behaviour of :from-end is possibly different from other versions of
102 this function; :from-end values of NIL and T are equivalent unless
103 :count is supplied. The second return value is an index suitable as an
104 argument to CL:SUBSEQ into the sequence indicating where processing
105 stopped."
106 (check-bounds sequence start end)
107 (if from-end
108 (split-from-end (lambda (sequence end)
109 (position-if predicate sequence :end end :from-end t :key key))
110 sequence start end count remove-empty-subseqs)
111 (split-from-start (lambda (sequence start)
112 (position-if predicate sequence :start start :key key))
113 sequence start end count remove-empty-subseqs)))
114
115 (defun split-sequence-if-not (predicate sequence &key (count nil) (remove-empty-subseqs nil)
116 (from-end nil) (start 0) (end nil) (key #'identity))
117 "Return a list of subsequences in seq delimited by items satisfying
118 \(CL:COMPLEMENT predicate).
119
120 If :remove-empty-subseqs is NIL, empty subsequences will be included
121 in the result; otherwise they will be discarded. All other keywords
122 work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
123 the behaviour of :from-end is possibly different from other versions
124 of this function; :from-end values of NIL and T are equivalent unless
125 :count is supplied. The second return value is an index suitable as an
126 argument to CL:SUBSEQ into the sequence indicating where processing
127 stopped."
128 (check-bounds sequence start end)
129 (if from-end
130 (split-from-end (lambda (sequence end)
131 (position-if-not predicate sequence :end end :from-end t :key key))
132 sequence start end count remove-empty-subseqs)
133 (split-from-start (lambda (sequence start)
134 (position-if-not predicate sequence :start start :key key))
135 sequence start end count remove-empty-subseqs))))
136
137 (defun split-from-end (position-fn sequence start end count remove-empty-subseqs)
138 (declare (optimize (speed 3) (debug 0)))
139 (loop
140 :for right := end :then left
141 :for left := (max (or (funcall position-fn sequence right) -1)
142 (1- start))
143 :unless (and (= right (1+ left))
144 remove-empty-subseqs) ; empty subseq we don't want
145 :if (and count (>= nr-elts count))
146 ;; We can't take any more. Return now.
147 :return (values (nreverse subseqs) right)
148 :else
149 :collect (subseq sequence (1+ left) right) into subseqs
150 :and :sum 1 :into nr-elts
151 :until (< left start)
152 :finally (return (values (nreverse subseqs) (1+ left)))))
153
154 (defun split-from-start (position-fn sequence start end count remove-empty-subseqs)
155 (declare (optimize (speed 3) (debug 0)))
156 (let ((length (length sequence)))
157 (loop
158 :for left := start :then (+ right 1)
159 :for right := (min (or (funcall position-fn sequence left) length)
160 end)
161 :unless (and (= right left)
162 remove-empty-subseqs) ; empty subseq we don't want
163 :if (and count (>= nr-elts count))
164 ;; We can't take any more. Return now.
165 :return (values subseqs left)
166 :else
167 :collect (subseq sequence left right) :into subseqs
168 :and :sum 1 :into nr-elts
169 :until (>= right end)
170 :finally (return (values subseqs right)))))
171
172 (pushnew :split-sequence *features*)