Mercurial > hg > xemacs-beta
annotate lisp/cl-seq.el @ 5067:7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
-------------------- ChangeLog entries follow: --------------------
lisp/ChangeLog addition:
2010-02-22 Ben Wing <ben@xemacs.org>
* cl-seq.el:
* cl-seq.el (stable-union): New.
* cl-seq.el (stable-intersection): New.
New functions to do stable set operations, i.e. preserve the order
of the elements in the argument lists, and prefer LIST1 over LIST2
when ordering the combined result. The result looks as much like
LIST1 as possible, followed (in the case of `stable-union') by
any necessary elements from LIST2, in order. This is contrary to
`union' and `intersection', which are not required to be order-
preserving and are not -- they prefer LIST2 and output results in
backwards order.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 22 Feb 2010 21:23:02 -0600 |
| parents | 545ec923b4eb |
| children | 6afe991b8135 |
| rev | line source |
|---|---|
| 613 | 1 ;;; cl-seq.el --- Common Lisp extensions for XEmacs Lisp (part three) |
| 428 | 2 |
| 3 ;; Copyright (C) 1993 Free Software Foundation, Inc. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
4 ;; Copyright (C) 2010 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Dave Gillespie <daveg@synaptics.com> | |
| 7 ;; Maintainer: XEmacs Development Team | |
| 8 ;; Version: 2.02 | |
| 9 ;; Keywords: extensions, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
| 13 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 14 ;; under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 21 ;; General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 26 ;; 02111-1307, USA. | |
| 27 | |
| 2153 | 28 ;;; Synched up with: FSF 21.3. |
| 428 | 29 |
| 30 ;;; Commentary: | |
| 31 | |
| 32 ;; This file is dumped with XEmacs. | |
| 33 | |
| 34 ;; These are extensions to Emacs Lisp that provide a degree of | |
| 35 ;; Common Lisp compatibility, beyond what is already built-in | |
| 36 ;; in Emacs Lisp. | |
| 37 ;; | |
| 38 ;; This package was written by Dave Gillespie; it is a complete | |
| 39 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
| 40 ;; | |
| 41 ;; This package works with Emacs 18, Emacs 19, and Lucid Emacs 19. | |
| 42 ;; | |
| 43 ;; Bug reports, comments, and suggestions are welcome! | |
| 44 | |
| 45 ;; This file contains the Common Lisp sequence and list functions | |
| 46 ;; which take keyword arguments. | |
| 47 | |
| 48 ;; See cl.el for Change Log. | |
| 49 | |
| 50 | |
| 51 ;;; Code: | |
| 52 | |
| 53 (or (memq 'cl-19 features) | |
| 54 (error "Tried to load `cl-seq' before `cl'!")) | |
| 55 | |
| 56 | |
| 57 ;;; Keyword parsing. This is special-cased here so that we can compile | |
| 58 ;;; this file independent from cl-macs. | |
| 59 | |
| 60 (defmacro cl-parsing-keywords (kwords other-keys &rest body) | |
| 442 | 61 "Helper macro for functions with keyword arguments. |
| 62 This is a temporary solution, until keyword arguments are natively supported. | |
| 63 Declare your function ending with (... &rest cl-keys), then wrap the | |
| 64 function body in a call to `cl-parsing-keywords'. | |
| 65 | |
| 66 KWORDS is a list of keyword definitions. Each definition should be | |
| 67 either a keyword or a list (KEYWORD DEFAULT-VALUE). In the former case, | |
| 68 the default value is nil. The keywords are available in BODY as the name | |
| 69 of the keyword, minus its initial colon and prepended with `cl-'. | |
| 70 | |
| 71 OTHER-KEYS specifies other keywords that are accepted but ignored. It | |
| 72 is either the value 't' (ignore all other keys, equivalent to the | |
| 73 &allow-other-keys argument declaration in Common Lisp) or a list in the | |
| 74 same format as KWORDS. If keywords are given that are not in KWORDS | |
| 75 and not allowed by OTHER-KEYS, an error will normally be signalled; but | |
| 76 the caller can override this by specifying a non-nil value for the | |
| 77 keyword :allow-other-keys (which defaults to t)." | |
| 428 | 78 (cons |
| 79 'let* | |
| 80 (cons (mapcar | |
| 81 (function | |
| 82 (lambda (x) | |
| 83 (let* ((var (if (consp x) (car x) x)) | |
| 84 (mem (list 'car (list 'cdr (list 'memq (list 'quote var) | |
| 85 'cl-keys))))) | |
| 2153 | 86 (if (eq var :test-not) |
| 428 | 87 (setq mem (list 'and mem (list 'setq 'cl-test mem) t))) |
| 2153 | 88 (if (eq var :if-not) |
| 428 | 89 (setq mem (list 'and mem (list 'setq 'cl-if mem) t))) |
| 90 (list (intern | |
| 91 (format "cl-%s" (substring (symbol-name var) 1))) | |
| 92 (if (consp x) (list 'or mem (car (cdr x))) mem))))) | |
| 93 kwords) | |
| 94 (append | |
| 95 (and (not (eq other-keys t)) | |
| 96 (list | |
| 97 (list 'let '((cl-keys-temp cl-keys)) | |
| 98 (list 'while 'cl-keys-temp | |
| 99 (list 'or (list 'memq '(car cl-keys-temp) | |
| 100 (list 'quote | |
| 101 (mapcar | |
| 102 (function | |
| 103 (lambda (x) | |
| 104 (if (consp x) | |
| 105 (car x) x))) | |
| 106 (append kwords | |
| 107 other-keys)))) | |
| 108 '(car (cdr (memq (quote :allow-other-keys) | |
| 109 cl-keys))) | |
| 110 '(error "Bad keyword argument %s" | |
| 111 (car cl-keys-temp))) | |
| 112 '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) | |
| 113 body)))) | |
| 114 (put 'cl-parsing-keywords 'lisp-indent-function 2) | |
| 115 (put 'cl-parsing-keywords 'edebug-form-spec '(sexp sexp &rest form)) | |
| 116 | |
| 117 (defmacro cl-check-key (x) | |
| 118 (list 'if 'cl-key (list 'funcall 'cl-key x) x)) | |
| 119 | |
| 120 (defmacro cl-check-test-nokey (item x) | |
| 121 (list 'cond | |
| 122 (list 'cl-test | |
| 123 (list 'eq (list 'not (list 'funcall 'cl-test item x)) | |
| 124 'cl-test-not)) | |
| 125 (list 'cl-if | |
| 126 (list 'eq (list 'not (list 'funcall 'cl-if x)) 'cl-if-not)) | |
| 127 (list 't (list 'if (list 'numberp item) | |
| 128 (list 'equal item x) (list 'eq item x))))) | |
| 129 | |
| 130 (defmacro cl-check-test (item x) | |
| 131 (list 'cl-check-test-nokey item (list 'cl-check-key x))) | |
| 132 | |
| 133 (defmacro cl-check-match (x y) | |
| 134 (setq x (list 'cl-check-key x) y (list 'cl-check-key y)) | |
| 135 (list 'if 'cl-test | |
| 136 (list 'eq (list 'not (list 'funcall 'cl-test x y)) 'cl-test-not) | |
| 137 (list 'if (list 'numberp x) | |
| 138 (list 'equal x y) (list 'eq x y)))) | |
| 139 | |
| 140 (put 'cl-check-key 'edebug-form-spec 'edebug-forms) | |
| 141 (put 'cl-check-test 'edebug-form-spec 'edebug-forms) | |
| 142 (put 'cl-check-test-nokey 'edebug-form-spec 'edebug-forms) | |
| 143 (put 'cl-check-match 'edebug-form-spec 'edebug-forms) | |
| 144 | |
| 145 (defvar cl-test) (defvar cl-test-not) | |
| 146 (defvar cl-if) (defvar cl-if-not) | |
| 147 (defvar cl-key) | |
| 148 | |
| 149 | |
| 150 (defun reduce (cl-func cl-seq &rest cl-keys) | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
151 "Combine the elements of sequence using FUNCTION, a binary operation. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
152 For example, `(reduce #'+ SEQUENCE)' returns the sum of all elements in |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
153 SEQUENCE, and `(reduce #'union SEQUENCE)' returns the union of all elements |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
154 in SEQUENCE. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
155 Keywords supported: :start :end :from-end :initial-value :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
156 See `remove*' for the meaning of :start, :end, :from-end and :key. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
157 :initial-value specifies an element (typically an identity element, such as 0) |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
158 that is conceptually prepended to the sequence (or appended, when :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
159 is given). |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
160 If the sequence has one element, that element is returned directly. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
161 If the sequence has no elements, :initial-value is returned if given; |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
162 otherwise, FUNCTION is called with no arguments, and its result returned." |
| 428 | 163 (cl-parsing-keywords (:from-end (:start 0) :end :initial-value :key) () |
| 164 (or (listp cl-seq) (setq cl-seq (append cl-seq nil))) | |
| 165 (setq cl-seq (subseq cl-seq cl-start cl-end)) | |
| 166 (if cl-from-end (setq cl-seq (nreverse cl-seq))) | |
| 2153 | 167 (let ((cl-accum (cond ((memq :initial-value cl-keys) cl-initial-value) |
| 168 (cl-seq (cl-check-key (pop cl-seq))) | |
| 428 | 169 (t (funcall cl-func))))) |
| 170 (if cl-from-end | |
| 171 (while cl-seq | |
| 2153 | 172 (setq cl-accum (funcall cl-func (cl-check-key (pop cl-seq)) |
| 428 | 173 cl-accum))) |
| 174 (while cl-seq | |
| 175 (setq cl-accum (funcall cl-func cl-accum | |
| 2153 | 176 (cl-check-key (pop cl-seq)))))) |
| 428 | 177 cl-accum))) |
| 178 | |
| 179 (defun fill (seq item &rest cl-keys) | |
| 180 "Fill the elements of SEQ with ITEM. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
181 Keywords supported: :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
182 :start and :end specify a subsequence of SEQ; see `remove*' for more |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
183 information." |
| 428 | 184 (cl-parsing-keywords ((:start 0) :end) () |
| 185 (if (listp seq) | |
| 186 (let ((p (nthcdr cl-start seq)) | |
| 187 (n (if cl-end (- cl-end cl-start) 8000000))) | |
| 188 (while (and p (>= (setq n (1- n)) 0)) | |
| 189 (setcar p item) | |
| 190 (setq p (cdr p)))) | |
| 191 (or cl-end (setq cl-end (length seq))) | |
| 192 (if (and (= cl-start 0) (= cl-end (length seq))) | |
| 193 (fillarray seq item) | |
| 194 (while (< cl-start cl-end) | |
| 195 (aset seq cl-start item) | |
| 196 (setq cl-start (1+ cl-start))))) | |
| 197 seq)) | |
| 198 | |
| 199 (defun replace (cl-seq1 cl-seq2 &rest cl-keys) | |
| 200 "Replace the elements of SEQ1 with the elements of SEQ2. | |
| 201 SEQ1 is destructively modified, then returned. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
202 Keywords supported: :start1 :end1 :start2 :end2 |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
203 :start1 and :end1 specify a subsequence of SEQ1, and :start2 and :end2 a |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
204 subsequence of SEQ2; see `search' for more information." |
| 428 | 205 (cl-parsing-keywords ((:start1 0) :end1 (:start2 0) :end2) () |
| 206 (if (and (eq cl-seq1 cl-seq2) (<= cl-start2 cl-start1)) | |
| 207 (or (= cl-start1 cl-start2) | |
| 208 (let* ((cl-len (length cl-seq1)) | |
| 209 (cl-n (min (- (or cl-end1 cl-len) cl-start1) | |
| 210 (- (or cl-end2 cl-len) cl-start2)))) | |
| 211 (while (>= (setq cl-n (1- cl-n)) 0) | |
| 212 (cl-set-elt cl-seq1 (+ cl-start1 cl-n) | |
| 213 (elt cl-seq2 (+ cl-start2 cl-n)))))) | |
| 214 (if (listp cl-seq1) | |
| 215 (let ((cl-p1 (nthcdr cl-start1 cl-seq1)) | |
| 216 (cl-n1 (if cl-end1 (- cl-end1 cl-start1) 4000000))) | |
| 217 (if (listp cl-seq2) | |
| 218 (let ((cl-p2 (nthcdr cl-start2 cl-seq2)) | |
| 219 (cl-n (min cl-n1 | |
| 220 (if cl-end2 (- cl-end2 cl-start2) 4000000)))) | |
| 221 (while (and cl-p1 cl-p2 (>= (setq cl-n (1- cl-n)) 0)) | |
| 222 (setcar cl-p1 (car cl-p2)) | |
| 223 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2)))) | |
| 224 (setq cl-end2 (min (or cl-end2 (length cl-seq2)) | |
| 225 (+ cl-start2 cl-n1))) | |
| 226 (while (and cl-p1 (< cl-start2 cl-end2)) | |
| 227 (setcar cl-p1 (aref cl-seq2 cl-start2)) | |
| 228 (setq cl-p1 (cdr cl-p1) cl-start2 (1+ cl-start2))))) | |
| 229 (setq cl-end1 (min (or cl-end1 (length cl-seq1)) | |
| 230 (+ cl-start1 (- (or cl-end2 (length cl-seq2)) | |
| 231 cl-start2)))) | |
| 232 (if (listp cl-seq2) | |
| 233 (let ((cl-p2 (nthcdr cl-start2 cl-seq2))) | |
| 234 (while (< cl-start1 cl-end1) | |
| 235 (aset cl-seq1 cl-start1 (car cl-p2)) | |
| 236 (setq cl-p2 (cdr cl-p2) cl-start1 (1+ cl-start1)))) | |
| 237 (while (< cl-start1 cl-end1) | |
| 238 (aset cl-seq1 cl-start1 (aref cl-seq2 cl-start2)) | |
| 239 (setq cl-start2 (1+ cl-start2) cl-start1 (1+ cl-start1)))))) | |
| 240 cl-seq1)) | |
| 241 | |
| 242 (defun remove* (cl-item cl-seq &rest cl-keys) | |
| 243 "Remove all occurrences of ITEM in SEQ. | |
| 244 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 245 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
246 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
247 The keywords :test and :test-not specify two-argument test and negated-test |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
248 predicates, respectively; :test defaults to `eql'. :key specifies a |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
249 one-argument function that transforms elements of SEQ into \"comparison keys\" |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
250 before the test predicate is applied. See `member*' for more information |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
251 on these keywords. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
252 :start and :end, if given, specify indices of a subsequence of SEQ to |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
253 be processed. Indices are 0-based and processing involves the subsequence |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
254 starting at the index given by :start and ending just before the index |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
255 given by :end. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
256 :count, if given, limits the number of items removed to the number specified. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
257 :from-end, if given, causes processing to proceed starting from the end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
258 instead of the beginning; in this case, this matters only if :count is given." |
| 428 | 259 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end |
| 260 (:start 0) :end) () | |
| 261 (if (<= (or cl-count (setq cl-count 8000000)) 0) | |
| 262 cl-seq | |
| 263 (if (or (nlistp cl-seq) (and cl-from-end (< cl-count 4000000))) | |
| 264 (let ((cl-i (cl-position cl-item cl-seq cl-start cl-end | |
| 265 cl-from-end))) | |
| 266 (if cl-i | |
| 267 (let ((cl-res (apply 'delete* cl-item (append cl-seq nil) | |
| 268 (append (if cl-from-end | |
| 2153 | 269 (list :end (1+ cl-i)) |
| 270 (list :start cl-i)) | |
| 428 | 271 cl-keys)))) |
| 272 (if (listp cl-seq) cl-res | |
| 273 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res)))) | |
| 274 cl-seq)) | |
| 275 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
| 276 (if (= cl-start 0) | |
| 277 (while (and cl-seq (> cl-end 0) | |
| 278 (cl-check-test cl-item (car cl-seq)) | |
| 279 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) | |
| 280 (> (setq cl-count (1- cl-count)) 0)))) | |
| 281 (if (and (> cl-count 0) (> cl-end 0)) | |
| 282 (let ((cl-p (if (> cl-start 0) (nthcdr cl-start cl-seq) | |
| 283 (setq cl-end (1- cl-end)) (cdr cl-seq)))) | |
| 284 (while (and cl-p (> cl-end 0) | |
| 285 (not (cl-check-test cl-item (car cl-p)))) | |
| 286 (setq cl-p (cdr cl-p) cl-end (1- cl-end))) | |
| 287 (if (and cl-p (> cl-end 0)) | |
| 288 (nconc (ldiff cl-seq cl-p) | |
| 289 (if (= cl-count 1) (cdr cl-p) | |
| 290 (and (cdr cl-p) | |
| 291 (apply 'delete* cl-item | |
| 292 (copy-sequence (cdr cl-p)) | |
| 2153 | 293 :start 0 :end (1- cl-end) |
| 294 :count (1- cl-count) cl-keys)))) | |
| 428 | 295 cl-seq)) |
| 296 cl-seq))))) | |
| 297 | |
| 298 (defun remove-if (cl-pred cl-list &rest cl-keys) | |
| 299 "Remove all items satisfying PREDICATE in SEQ. | |
| 300 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 301 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
302 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
303 See `remove*' for the meaning of the keywords." |
| 2153 | 304 (apply 'remove* nil cl-list :if cl-pred cl-keys)) |
| 428 | 305 |
| 306 (defun remove-if-not (cl-pred cl-list &rest cl-keys) | |
| 307 "Remove all items not satisfying PREDICATE in SEQ. | |
| 308 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 309 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
310 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
311 See `remove*' for the meaning of the keywords." |
| 2153 | 312 (apply 'remove* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 313 |
| 314 (defun delete* (cl-item cl-seq &rest cl-keys) | |
| 315 "Remove all occurrences of ITEM in SEQ. | |
| 316 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
317 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
318 See `remove*' for the meaning of the keywords." |
| 428 | 319 (cl-parsing-keywords (:test :test-not :key :if :if-not :count :from-end |
| 320 (:start 0) :end) () | |
| 321 (if (<= (or cl-count (setq cl-count 8000000)) 0) | |
| 322 cl-seq | |
| 323 (if (listp cl-seq) | |
| 324 (if (and cl-from-end (< cl-count 4000000)) | |
| 325 (let (cl-i) | |
| 326 (while (and (>= (setq cl-count (1- cl-count)) 0) | |
| 327 (setq cl-i (cl-position cl-item cl-seq cl-start | |
| 328 cl-end cl-from-end))) | |
| 329 (if (= cl-i 0) (setq cl-seq (cdr cl-seq)) | |
| 330 (let ((cl-tail (nthcdr (1- cl-i) cl-seq))) | |
| 331 (setcdr cl-tail (cdr (cdr cl-tail))))) | |
| 332 (setq cl-end cl-i)) | |
| 333 cl-seq) | |
| 334 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
| 335 (if (= cl-start 0) | |
| 336 (progn | |
| 337 (while (and cl-seq | |
| 338 (> cl-end 0) | |
| 339 (cl-check-test cl-item (car cl-seq)) | |
| 340 (setq cl-end (1- cl-end) cl-seq (cdr cl-seq)) | |
| 341 (> (setq cl-count (1- cl-count)) 0))) | |
| 342 (setq cl-end (1- cl-end))) | |
| 343 (setq cl-start (1- cl-start))) | |
| 344 (if (and (> cl-count 0) (> cl-end 0)) | |
| 345 (let ((cl-p (nthcdr cl-start cl-seq))) | |
| 346 (while (and (cdr cl-p) (> cl-end 0)) | |
| 347 (if (cl-check-test cl-item (car (cdr cl-p))) | |
| 348 (progn | |
| 349 (setcdr cl-p (cdr (cdr cl-p))) | |
| 350 (if (= (setq cl-count (1- cl-count)) 0) | |
| 351 (setq cl-end 1))) | |
| 352 (setq cl-p (cdr cl-p))) | |
| 353 (setq cl-end (1- cl-end))))) | |
| 354 cl-seq) | |
| 355 (apply 'remove* cl-item cl-seq cl-keys))))) | |
| 356 | |
| 357 (defun delete-if (cl-pred cl-list &rest cl-keys) | |
| 358 "Remove all items satisfying PREDICATE in SEQ. | |
| 359 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
360 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
361 See `remove*' for the meaning of the keywords." |
| 2153 | 362 (apply 'delete* nil cl-list :if cl-pred cl-keys)) |
| 428 | 363 |
| 364 (defun delete-if-not (cl-pred cl-list &rest cl-keys) | |
| 365 "Remove all items not satisfying PREDICATE in SEQ. | |
| 366 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
367 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
368 See `remove*' for the meaning of the keywords." |
| 2153 | 369 (apply 'delete* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 370 |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
371 ;; XEmacs change: this is in subr.el in GNU Emacs |
| 428 | 372 (defun remove (cl-item cl-seq) |
| 373 "Remove all occurrences of ITEM in SEQ, testing with `equal' | |
| 374 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 375 to avoid corrupting the original SEQ. | |
| 376 Also see: `remove*', `delete', `delete*'" | |
| 377 (remove* cl-item cl-seq ':test 'equal)) | |
| 378 | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
379 ;; XEmacs change: this is in subr.el in GNU Emacs |
| 428 | 380 (defun remq (cl-elt cl-list) |
| 442 | 381 "Remove all occurrences of ELT in LIST, comparing with `eq'. |
| 428 | 382 This is a non-destructive function; it makes a copy of LIST to avoid |
| 383 corrupting the original LIST. | |
| 384 Also see: `delq', `delete', `delete*', `remove', `remove*'." | |
| 385 (if (memq cl-elt cl-list) | |
| 386 (delq cl-elt (copy-list cl-list)) | |
| 387 cl-list)) | |
| 388 | |
| 389 (defun remove-duplicates (cl-seq &rest cl-keys) | |
| 390 "Return a copy of SEQ with all duplicate elements removed. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
391 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
392 See `remove*' for the meaning of the keywords." |
| 428 | 393 (cl-delete-duplicates cl-seq cl-keys t)) |
| 394 | |
| 395 (defun delete-duplicates (cl-seq &rest cl-keys) | |
| 396 "Remove all duplicate elements from SEQ (destructively). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
397 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
398 See `remove*' for the meaning of the keywords." |
| 428 | 399 (cl-delete-duplicates cl-seq cl-keys nil)) |
| 400 | |
| 401 (defun cl-delete-duplicates (cl-seq cl-keys cl-copy) | |
| 402 (if (listp cl-seq) | |
| 403 (cl-parsing-keywords (:test :test-not :key (:start 0) :end :from-end :if) | |
| 404 () | |
| 405 (if cl-from-end | |
| 406 (let ((cl-p (nthcdr cl-start cl-seq)) cl-i) | |
| 407 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) | |
| 408 (while (> cl-end 1) | |
| 409 (setq cl-i 0) | |
| 410 (while (setq cl-i (cl-position (cl-check-key (car cl-p)) | |
| 411 (cdr cl-p) cl-i (1- cl-end))) | |
| 412 (if cl-copy (setq cl-seq (copy-sequence cl-seq) | |
| 413 cl-p (nthcdr cl-start cl-seq) cl-copy nil)) | |
| 414 (let ((cl-tail (nthcdr cl-i cl-p))) | |
| 415 (setcdr cl-tail (cdr (cdr cl-tail)))) | |
| 416 (setq cl-end (1- cl-end))) | |
| 417 (setq cl-p (cdr cl-p) cl-end (1- cl-end) | |
| 418 cl-start (1+ cl-start))) | |
| 419 cl-seq) | |
| 420 (setq cl-end (- (or cl-end (length cl-seq)) cl-start)) | |
| 421 (while (and (cdr cl-seq) (= cl-start 0) (> cl-end 1) | |
| 422 (cl-position (cl-check-key (car cl-seq)) | |
| 423 (cdr cl-seq) 0 (1- cl-end))) | |
| 424 (setq cl-seq (cdr cl-seq) cl-end (1- cl-end))) | |
| 425 (let ((cl-p (if (> cl-start 0) (nthcdr (1- cl-start) cl-seq) | |
| 426 (setq cl-end (1- cl-end) cl-start 1) cl-seq))) | |
| 427 (while (and (cdr (cdr cl-p)) (> cl-end 1)) | |
| 428 (if (cl-position (cl-check-key (car (cdr cl-p))) | |
| 429 (cdr (cdr cl-p)) 0 (1- cl-end)) | |
| 430 (progn | |
| 431 (if cl-copy (setq cl-seq (copy-sequence cl-seq) | |
| 432 cl-p (nthcdr (1- cl-start) cl-seq) | |
| 433 cl-copy nil)) | |
| 434 (setcdr cl-p (cdr (cdr cl-p)))) | |
| 435 (setq cl-p (cdr cl-p))) | |
| 436 (setq cl-end (1- cl-end) cl-start (1+ cl-start))) | |
| 437 cl-seq))) | |
| 438 (let ((cl-res (cl-delete-duplicates (append cl-seq nil) cl-keys nil))) | |
| 439 (if (stringp cl-seq) (concat cl-res) (vconcat cl-res))))) | |
| 440 | |
| 441 (defun substitute (cl-new cl-old cl-seq &rest cl-keys) | |
| 442 "Substitute NEW for OLD in SEQ. | |
| 443 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 444 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
445 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
446 See `remove*' for the meaning of the keywords." |
| 428 | 447 (cl-parsing-keywords (:test :test-not :key :if :if-not :count |
| 448 (:start 0) :end :from-end) () | |
| 449 (if (or (eq cl-old cl-new) | |
| 450 (<= (or cl-count (setq cl-from-end nil cl-count 8000000)) 0)) | |
| 451 cl-seq | |
| 452 (let ((cl-i (cl-position cl-old cl-seq cl-start cl-end))) | |
| 453 (if (not cl-i) | |
| 454 cl-seq | |
| 455 (setq cl-seq (copy-sequence cl-seq)) | |
| 456 (or cl-from-end | |
| 457 (progn (cl-set-elt cl-seq cl-i cl-new) | |
| 458 (setq cl-i (1+ cl-i) cl-count (1- cl-count)))) | |
| 2153 | 459 (apply 'nsubstitute cl-new cl-old cl-seq :count cl-count |
| 460 :start cl-i cl-keys)))))) | |
| 428 | 461 |
| 462 (defun substitute-if (cl-new cl-pred cl-list &rest cl-keys) | |
| 463 "Substitute NEW for all items satisfying PREDICATE in SEQ. | |
| 464 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 465 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
466 See `remove*' for the meaning of the keywords." |
| 2153 | 467 (apply 'substitute cl-new nil cl-list :if cl-pred cl-keys)) |
| 428 | 468 |
| 469 (defun substitute-if-not (cl-new cl-pred cl-list &rest cl-keys) | |
| 470 "Substitute NEW for all items not satisfying PREDICATE in SEQ. | |
| 471 This is a non-destructive function; it makes a copy of SEQ if necessary | |
| 472 to avoid corrupting the original SEQ. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
473 See `remove*' for the meaning of the keywords." |
| 2153 | 474 (apply 'substitute cl-new nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 475 |
| 476 (defun nsubstitute (cl-new cl-old cl-seq &rest cl-keys) | |
| 477 "Substitute NEW for OLD in SEQ. | |
| 478 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
479 Keywords supported: :test :test-not :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
480 See `remove*' for the meaning of the keywords." |
| 428 | 481 (cl-parsing-keywords (:test :test-not :key :if :if-not :count |
| 482 (:start 0) :end :from-end) () | |
| 483 (or (eq cl-old cl-new) (<= (or cl-count (setq cl-count 8000000)) 0) | |
| 484 (if (and (listp cl-seq) (or (not cl-from-end) (> cl-count 4000000))) | |
| 485 (let ((cl-p (nthcdr cl-start cl-seq))) | |
| 486 (setq cl-end (- (or cl-end 8000000) cl-start)) | |
| 487 (while (and cl-p (> cl-end 0) (> cl-count 0)) | |
| 488 (if (cl-check-test cl-old (car cl-p)) | |
| 489 (progn | |
| 490 (setcar cl-p cl-new) | |
| 491 (setq cl-count (1- cl-count)))) | |
| 492 (setq cl-p (cdr cl-p) cl-end (1- cl-end)))) | |
| 493 (or cl-end (setq cl-end (length cl-seq))) | |
| 494 (if cl-from-end | |
| 495 (while (and (< cl-start cl-end) (> cl-count 0)) | |
| 496 (setq cl-end (1- cl-end)) | |
| 497 (if (cl-check-test cl-old (elt cl-seq cl-end)) | |
| 498 (progn | |
| 499 (cl-set-elt cl-seq cl-end cl-new) | |
| 500 (setq cl-count (1- cl-count))))) | |
| 501 (while (and (< cl-start cl-end) (> cl-count 0)) | |
| 502 (if (cl-check-test cl-old (aref cl-seq cl-start)) | |
| 503 (progn | |
| 504 (aset cl-seq cl-start cl-new) | |
| 505 (setq cl-count (1- cl-count)))) | |
| 506 (setq cl-start (1+ cl-start)))))) | |
| 507 cl-seq)) | |
| 508 | |
| 509 (defun nsubstitute-if (cl-new cl-pred cl-list &rest cl-keys) | |
| 510 "Substitute NEW for all items satisfying PREDICATE in SEQ. | |
| 511 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
512 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
513 See `remove*' for the meaning of the keywords." |
| 2153 | 514 (apply 'nsubstitute cl-new nil cl-list :if cl-pred cl-keys)) |
| 428 | 515 |
| 516 (defun nsubstitute-if-not (cl-new cl-pred cl-list &rest cl-keys) | |
| 517 "Substitute NEW for all items not satisfying PREDICATE in SEQ. | |
| 518 This is a destructive function; it reuses the storage of SEQ whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
519 Keywords supported: :key :count :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
520 See `remove*' for the meaning of the keywords." |
| 2153 | 521 (apply 'nsubstitute cl-new nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 522 |
| 523 (defun find (cl-item cl-seq &rest cl-keys) | |
| 524 "Find the first occurrence of ITEM in LIST. | |
| 525 Return the matching ITEM, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
526 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
527 See `remove*' for the meaning of the keywords." |
| 428 | 528 (let ((cl-pos (apply 'position cl-item cl-seq cl-keys))) |
| 529 (and cl-pos (elt cl-seq cl-pos)))) | |
| 530 | |
| 531 (defun find-if (cl-pred cl-list &rest cl-keys) | |
| 532 "Find the first item satisfying PREDICATE in LIST. | |
| 533 Return the matching ITEM, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
534 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
535 See `remove*' for the meaning of the keywords." |
| 2153 | 536 (apply 'find nil cl-list :if cl-pred cl-keys)) |
| 428 | 537 |
| 538 (defun find-if-not (cl-pred cl-list &rest cl-keys) | |
| 539 "Find the first item not satisfying PREDICATE in LIST. | |
| 540 Return the matching ITEM, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
541 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
542 See `remove*' for the meaning of the keywords." |
| 2153 | 543 (apply 'find nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 544 |
| 545 (defun position (cl-item cl-seq &rest cl-keys) | |
| 546 "Find the first occurrence of ITEM in LIST. | |
| 547 Return the index of the matching item, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
548 Keywords supported: :test :test-not :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
549 See `remove*' for the meaning of the keywords." |
| 428 | 550 (cl-parsing-keywords (:test :test-not :key :if :if-not |
| 551 (:start 0) :end :from-end) () | |
| 552 (cl-position cl-item cl-seq cl-start cl-end cl-from-end))) | |
| 553 | |
| 554 (defun cl-position (cl-item cl-seq cl-start &optional cl-end cl-from-end) | |
| 555 (if (listp cl-seq) | |
| 556 (let ((cl-p (nthcdr cl-start cl-seq))) | |
| 557 (or cl-end (setq cl-end 8000000)) | |
| 558 (let ((cl-res nil)) | |
| 559 (while (and cl-p (< cl-start cl-end) (or (not cl-res) cl-from-end)) | |
| 560 (if (cl-check-test cl-item (car cl-p)) | |
| 561 (setq cl-res cl-start)) | |
| 562 (setq cl-p (cdr cl-p) cl-start (1+ cl-start))) | |
| 563 cl-res)) | |
| 564 (or cl-end (setq cl-end (length cl-seq))) | |
| 565 (if cl-from-end | |
| 566 (progn | |
| 567 (while (and (>= (setq cl-end (1- cl-end)) cl-start) | |
| 568 (not (cl-check-test cl-item (aref cl-seq cl-end))))) | |
| 569 (and (>= cl-end cl-start) cl-end)) | |
| 570 (while (and (< cl-start cl-end) | |
| 571 (not (cl-check-test cl-item (aref cl-seq cl-start)))) | |
| 572 (setq cl-start (1+ cl-start))) | |
| 573 (and (< cl-start cl-end) cl-start)))) | |
| 574 | |
| 575 (defun position-if (cl-pred cl-list &rest cl-keys) | |
| 576 "Find the first item satisfying PREDICATE in LIST. | |
| 577 Return the index of the matching item, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
578 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
579 See `remove*' for the meaning of the keywords." |
| 2153 | 580 (apply 'position nil cl-list :if cl-pred cl-keys)) |
| 428 | 581 |
| 582 (defun position-if-not (cl-pred cl-list &rest cl-keys) | |
| 583 "Find the first item not satisfying PREDICATE in LIST. | |
| 584 Return the index of the matching item, or nil if not found. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
585 Keywords supported: :key :start :end :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
586 See `remove*' for the meaning of the keywords." |
| 2153 | 587 (apply 'position nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 588 |
| 589 (defun count (cl-item cl-seq &rest cl-keys) | |
| 590 "Count the number of occurrences of ITEM in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
591 Keywords supported: :test :test-not :key :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
592 See `remove*' for the meaning of the keywords." |
| 428 | 593 (cl-parsing-keywords (:test :test-not :key :if :if-not (:start 0) :end) () |
| 594 (let ((cl-count 0) cl-x) | |
| 595 (or cl-end (setq cl-end (length cl-seq))) | |
| 596 (if (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) | |
| 597 (while (< cl-start cl-end) | |
| 2153 | 598 (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) |
| 428 | 599 (if (cl-check-test cl-item cl-x) (setq cl-count (1+ cl-count))) |
| 600 (setq cl-start (1+ cl-start))) | |
| 601 cl-count))) | |
| 602 | |
| 603 (defun count-if (cl-pred cl-list &rest cl-keys) | |
| 604 "Count the number of items satisfying PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
605 Keywords supported: :key :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
606 See `remove*' for the meaning of the keywords." |
| 2153 | 607 (apply 'count nil cl-list :if cl-pred cl-keys)) |
| 428 | 608 |
| 609 (defun count-if-not (cl-pred cl-list &rest cl-keys) | |
| 610 "Count the number of items not satisfying PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
611 Keywords supported: :key :start :end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
612 See `remove*' for the meaning of the keywords." |
| 2153 | 613 (apply 'count nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 614 |
| 615 (defun mismatch (cl-seq1 cl-seq2 &rest cl-keys) | |
| 616 "Compare SEQ1 with SEQ2, return index of first mismatching element. | |
| 617 Return nil if the sequences match. If one sequence is a prefix of the | |
| 2153 | 618 other, the return value indicates the end of the shorter sequence. |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
619 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
620 See `search' for the meaning of the keywords." |
| 428 | 621 (cl-parsing-keywords (:test :test-not :key :from-end |
| 622 (:start1 0) :end1 (:start2 0) :end2) () | |
| 623 (or cl-end1 (setq cl-end1 (length cl-seq1))) | |
| 624 (or cl-end2 (setq cl-end2 (length cl-seq2))) | |
| 625 (if cl-from-end | |
| 626 (progn | |
| 627 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) | |
| 628 (cl-check-match (elt cl-seq1 (1- cl-end1)) | |
| 629 (elt cl-seq2 (1- cl-end2)))) | |
| 630 (setq cl-end1 (1- cl-end1) cl-end2 (1- cl-end2))) | |
| 631 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) | |
| 632 (1- cl-end1))) | |
| 633 (let ((cl-p1 (and (listp cl-seq1) (nthcdr cl-start1 cl-seq1))) | |
| 634 (cl-p2 (and (listp cl-seq2) (nthcdr cl-start2 cl-seq2)))) | |
| 635 (while (and (< cl-start1 cl-end1) (< cl-start2 cl-end2) | |
| 636 (cl-check-match (if cl-p1 (car cl-p1) | |
| 637 (aref cl-seq1 cl-start1)) | |
| 638 (if cl-p2 (car cl-p2) | |
| 639 (aref cl-seq2 cl-start2)))) | |
| 640 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2) | |
| 641 cl-start1 (1+ cl-start1) cl-start2 (1+ cl-start2))) | |
| 642 (and (or (< cl-start1 cl-end1) (< cl-start2 cl-end2)) | |
| 643 cl-start1))))) | |
| 644 | |
| 645 (defun search (cl-seq1 cl-seq2 &rest cl-keys) | |
| 646 "Search for SEQ1 as a subsequence of SEQ2. | |
| 647 Return the index of the leftmost element of the first match found; | |
| 648 return nil if there are no matches. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
649 Keywords supported: :test :test-not :key :start1 :end1 :start2 :end2 :from-end |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
650 See `remove*' for the meaning of the keywords. In this case, :start1 and :end1 |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
651 specify a subsequence of SEQ1, and :start2 and :end2 specify a subsequence |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
652 of SEQ2." |
| 428 | 653 (cl-parsing-keywords (:test :test-not :key :from-end |
| 654 (:start1 0) :end1 (:start2 0) :end2) () | |
| 655 (or cl-end1 (setq cl-end1 (length cl-seq1))) | |
| 656 (or cl-end2 (setq cl-end2 (length cl-seq2))) | |
| 657 (if (>= cl-start1 cl-end1) | |
| 658 (if cl-from-end cl-end2 cl-start2) | |
| 659 (let* ((cl-len (- cl-end1 cl-start1)) | |
| 660 (cl-first (cl-check-key (elt cl-seq1 cl-start1))) | |
| 661 (cl-if nil) cl-pos) | |
| 662 (setq cl-end2 (- cl-end2 (1- cl-len))) | |
| 663 (while (and (< cl-start2 cl-end2) | |
| 664 (setq cl-pos (cl-position cl-first cl-seq2 | |
| 665 cl-start2 cl-end2 cl-from-end)) | |
| 666 (apply 'mismatch cl-seq1 cl-seq2 | |
| 2153 | 667 :start1 (1+ cl-start1) :end1 cl-end1 |
| 668 :start2 (1+ cl-pos) :end2 (+ cl-pos cl-len) | |
| 669 :from-end nil cl-keys)) | |
| 428 | 670 (if cl-from-end (setq cl-end2 cl-pos) (setq cl-start2 (1+ cl-pos)))) |
| 671 (and (< cl-start2 cl-end2) cl-pos))))) | |
| 672 | |
| 673 (defun sort* (cl-seq cl-pred &rest cl-keys) | |
| 674 "Sort the argument SEQUENCE according to PREDICATE. | |
| 675 This is a destructive function; it reuses the storage of SEQUENCE if possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
676 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
677 :key specifies a one-argument function that transforms elements of SEQUENCE |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
678 into \"comparison keys\" before the test predicate is applied. See |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
679 `member*' for more information." |
| 428 | 680 (if (nlistp cl-seq) |
| 681 (replace cl-seq (apply 'sort* (append cl-seq nil) cl-pred cl-keys)) | |
| 682 (cl-parsing-keywords (:key) () | |
| 683 (if (memq cl-key '(nil identity)) | |
| 684 (sort cl-seq cl-pred) | |
| 685 (sort cl-seq (function (lambda (cl-x cl-y) | |
| 686 (funcall cl-pred (funcall cl-key cl-x) | |
| 687 (funcall cl-key cl-y))))))))) | |
| 688 | |
| 689 (defun stable-sort (cl-seq cl-pred &rest cl-keys) | |
| 690 "Sort the argument SEQUENCE stably according to PREDICATE. | |
| 691 This is a destructive function; it reuses the storage of SEQUENCE if possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
692 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
693 :key specifies a one-argument function that transforms elements of SEQUENCE |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
694 into \"comparison keys\" before the test predicate is applied. See |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
695 `member*' for more information." |
| 428 | 696 (apply 'sort* cl-seq cl-pred cl-keys)) |
| 697 | |
| 698 (defun merge (cl-type cl-seq1 cl-seq2 cl-pred &rest cl-keys) | |
| 699 "Destructively merge the two sequences to produce a new sequence. | |
| 700 TYPE is the sequence type to return, SEQ1 and SEQ2 are the two | |
| 701 argument sequences, and PRED is a `less-than' predicate on the elements. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
702 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
703 :key specifies a one-argument function that transforms elements of SEQ1 and |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
704 SEQ2 into \"comparison keys\" before the test predicate is applied. See |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
705 `member*' for more information." |
| 428 | 706 (or (listp cl-seq1) (setq cl-seq1 (append cl-seq1 nil))) |
| 707 (or (listp cl-seq2) (setq cl-seq2 (append cl-seq2 nil))) | |
| 708 (cl-parsing-keywords (:key) () | |
| 709 (let ((cl-res nil)) | |
| 710 (while (and cl-seq1 cl-seq2) | |
| 711 (if (funcall cl-pred (cl-check-key (car cl-seq2)) | |
| 712 (cl-check-key (car cl-seq1))) | |
| 2153 | 713 (push (pop cl-seq2) cl-res) |
| 714 (push (pop cl-seq1) cl-res))) | |
| 428 | 715 (coerce (nconc (nreverse cl-res) cl-seq1 cl-seq2) cl-type)))) |
| 716 | |
| 717 ;;; See compiler macro in cl-macs.el | |
| 718 (defun member* (cl-item cl-list &rest cl-keys) | |
| 719 "Find the first occurrence of ITEM in LIST. | |
| 720 Return the sublist of LIST whose car is ITEM. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
721 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
722 The keyword :test specifies a two-argument function that is used to |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
723 compare ITEM with elements in LIST; if omitted, it defaults to `eql'. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
724 The keyword :test-not is similar, but specifies a negated predicate. That |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
725 is, ITEM is considered equal to an element in LIST if the given predicate |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
726 returns nil. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
727 :key specifies a one-argument function that transforms elements of LIST into |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
728 \"comparison keys\" before the test predicate is applied. For example, |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
729 if :key is #'car, then ITEM is compared with the car of elements from LIST1. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
730 The :key function, however, is not applied to ITEM, and does not affect the |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
731 elements in the returned list, which are taken directly from the elements in |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
732 LIST." |
| 428 | 733 (if cl-keys |
| 734 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
| 735 (while (and cl-list (not (cl-check-test cl-item (car cl-list)))) | |
| 736 (setq cl-list (cdr cl-list))) | |
| 737 cl-list) | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
738 (if (and (numberp cl-item) (not (fixnump cl-item))) |
| 428 | 739 (member cl-item cl-list) |
| 740 (memq cl-item cl-list)))) | |
| 741 | |
| 742 (defun member-if (cl-pred cl-list &rest cl-keys) | |
| 743 "Find the first item satisfying PREDICATE in LIST. | |
| 744 Return the sublist of LIST whose car matches. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
745 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
746 See `member*' for the meaning of :key." |
| 2153 | 747 (apply 'member* nil cl-list :if cl-pred cl-keys)) |
| 428 | 748 |
| 749 (defun member-if-not (cl-pred cl-list &rest cl-keys) | |
| 750 "Find the first item not satisfying PREDICATE in LIST. | |
| 751 Return the sublist of LIST whose car matches. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
752 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
753 See `member*' for the meaning of :key." |
| 2153 | 754 (apply 'member* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 755 |
| 756 (defun cl-adjoin (cl-item cl-list &rest cl-keys) | |
| 757 (if (cl-parsing-keywords (:key) t | |
| 758 (apply 'member* (cl-check-key cl-item) cl-list cl-keys)) | |
| 759 cl-list | |
| 760 (cons cl-item cl-list))) | |
| 761 | |
| 762 ;;; See compiler macro in cl-macs.el | |
| 763 (defun assoc* (cl-item cl-alist &rest cl-keys) | |
| 764 "Find the first item whose car matches ITEM in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
765 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
766 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 767 (if cl-keys |
| 768 (cl-parsing-keywords (:test :test-not :key :if :if-not) () | |
| 769 (while (and cl-alist | |
| 770 (or (not (consp (car cl-alist))) | |
| 771 (not (cl-check-test cl-item (car (car cl-alist)))))) | |
| 772 (setq cl-alist (cdr cl-alist))) | |
| 773 (and cl-alist (car cl-alist))) | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
774 (if (and (numberp cl-item) (not (fixnump cl-item))) |
| 428 | 775 (assoc cl-item cl-alist) |
| 776 (assq cl-item cl-alist)))) | |
| 777 | |
| 778 (defun assoc-if (cl-pred cl-list &rest cl-keys) | |
| 779 "Find the first item whose car satisfies PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
780 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
781 See `member*' for the meaning of :key." |
| 2153 | 782 (apply 'assoc* nil cl-list :if cl-pred cl-keys)) |
| 428 | 783 |
| 784 (defun assoc-if-not (cl-pred cl-list &rest cl-keys) | |
| 785 "Find the first item whose car does not satisfy PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
786 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
787 See `member*' for the meaning of :key." |
| 2153 | 788 (apply 'assoc* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 789 |
| 790 (defun rassoc* (cl-item cl-alist &rest cl-keys) | |
| 791 "Find the first item whose cdr matches ITEM in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
792 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
793 See `member*' for the meaning of :test, :test-not and :key." |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
2153
diff
changeset
|
794 (if (or cl-keys (and (numberp cl-item) (not (fixnump cl-item)))) |
| 428 | 795 (cl-parsing-keywords (:test :test-not :key :if :if-not) () |
| 796 (while (and cl-alist | |
| 797 (or (not (consp (car cl-alist))) | |
| 798 (not (cl-check-test cl-item (cdr (car cl-alist)))))) | |
| 799 (setq cl-alist (cdr cl-alist))) | |
| 800 (and cl-alist (car cl-alist))) | |
| 801 (rassq cl-item cl-alist))) | |
| 802 | |
| 803 (defun rassoc-if (cl-pred cl-list &rest cl-keys) | |
| 804 "Find the first item whose cdr satisfies PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
805 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
806 See `member*' for the meaning of :key." |
| 2153 | 807 (apply 'rassoc* nil cl-list :if cl-pred cl-keys)) |
| 428 | 808 |
| 809 (defun rassoc-if-not (cl-pred cl-list &rest cl-keys) | |
| 810 "Find the first item whose cdr does not satisfy PREDICATE in LIST. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
811 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
812 See `member*' for the meaning of :key." |
| 2153 | 813 (apply 'rassoc* nil cl-list :if-not cl-pred cl-keys)) |
| 428 | 814 |
| 815 (defun union (cl-list1 cl-list2 &rest cl-keys) | |
| 816 "Combine LIST1 and LIST2 using a set-union operation. | |
| 817 The result list contains all items that appear in either LIST1 or LIST2. | |
| 818 This is a non-destructive function; it makes a copy of the data if necessary | |
| 819 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
820 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
821 The keywords :test and :test-not specify two-argument test and negated-test |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
822 predicates, respectively; :test defaults to `eql'. see `member*' for more |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
823 information. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
824 :key specifies a one-argument function that transforms elements of LIST1 |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
825 and LIST2 into \"comparison keys\" before the test predicate is applied. |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
826 For example, if :key is #'car, then the car of elements from LIST1 is |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
827 compared with the car of elements from LIST2. The :key function, however, |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
828 does not affect the elements in the returned list, which are taken directly |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
829 from the elements in LIST1 and LIST2." |
| 428 | 830 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 831 ((equal cl-list1 cl-list2) cl-list1) | |
| 832 (t | |
| 833 (or (>= (length cl-list1) (length cl-list2)) | |
| 834 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) | |
| 835 (while cl-list2 | |
| 836 (if (or cl-keys (numberp (car cl-list2))) | |
| 837 (setq cl-list1 (apply 'adjoin (car cl-list2) cl-list1 cl-keys)) | |
| 838 (or (memq (car cl-list2) cl-list1) | |
| 2153 | 839 (push (car cl-list2) cl-list1))) |
| 840 (pop cl-list2)) | |
| 428 | 841 cl-list1))) |
| 842 | |
| 843 (defun nunion (cl-list1 cl-list2 &rest cl-keys) | |
| 844 "Combine LIST1 and LIST2 using a set-union operation. | |
| 845 The result list contains all items that appear in either LIST1 or LIST2. | |
| 846 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 847 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
848 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
849 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 850 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 851 (t (apply 'union cl-list1 cl-list2 cl-keys)))) | |
| 852 | |
|
5067
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
853 ;; XEmacs addition: NOT IN COMMON LISP. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
854 (defun stable-union (cl-list1 cl-list2 &rest cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
855 "Stably combine LIST1 and LIST2 using a set-union operation. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
856 The result list contains all items that appear in either LIST1 or LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
857 The result is \"stable\" in that it preserves the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
858 LIST1 and LIST2. The result specifically consists of the elements in LIST1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
859 in order, followed by any elements in LIST2 that are not also in LIST1, in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
860 the order given in LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
861 This is a non-destructive function; it makes a copy of the data if necessary |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
862 to avoid corrupting the original LIST1 and LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
863 Keywords supported: :test :test-not :key |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
864 See `union' for the meaning of :test, :test-not and :key. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
865 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
866 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
867 extension." |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
868 ;; The standard `union' doesn't produce a "stable" union -- |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
869 ;; it iterates over the second list instead of the first one, and returns |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
870 ;; the values in backwards order. According to the CLTL2 documentation, |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
871 ;; `union' is not required to preserve the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
872 ;; any fashion, so we add a new function rather than changing the |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
873 ;; semantics of `union'. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
874 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
875 ((equal cl-list1 cl-list2) cl-list1) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
876 (t |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
877 (append |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
878 cl-list1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
879 (cl-parsing-keywords (:key) (:test :test-not) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
880 (loop for cl-l in cl-list2 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
881 if (not (if (or cl-keys (numberp cl-l)) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
882 (apply 'member* (cl-check-key cl-l) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
883 cl-list1 cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
884 (memq cl-l cl-list1))) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
885 collect cl-l)))))) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
886 |
| 428 | 887 (defun intersection (cl-list1 cl-list2 &rest cl-keys) |
| 888 "Combine LIST1 and LIST2 using a set-intersection operation. | |
| 889 The result list contains all items that appear in both LIST1 and LIST2. | |
| 890 This is a non-destructive function; it makes a copy of the data if necessary | |
| 891 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
892 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
893 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 894 (and cl-list1 cl-list2 |
| 895 (if (equal cl-list1 cl-list2) cl-list1 | |
| 896 (cl-parsing-keywords (:key) (:test :test-not) | |
| 897 (let ((cl-res nil)) | |
| 898 (or (>= (length cl-list1) (length cl-list2)) | |
| 899 (setq cl-list1 (prog1 cl-list2 (setq cl-list2 cl-list1)))) | |
| 900 (while cl-list2 | |
| 901 (if (if (or cl-keys (numberp (car cl-list2))) | |
| 902 (apply 'member* (cl-check-key (car cl-list2)) | |
| 903 cl-list1 cl-keys) | |
| 904 (memq (car cl-list2) cl-list1)) | |
| 2153 | 905 (push (car cl-list2) cl-res)) |
| 906 (pop cl-list2)) | |
| 428 | 907 cl-res))))) |
| 908 | |
| 909 (defun nintersection (cl-list1 cl-list2 &rest cl-keys) | |
| 910 "Combine LIST1 and LIST2 using a set-intersection operation. | |
| 911 The result list contains all items that appear in both LIST1 and LIST2. | |
| 912 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 913 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
914 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
915 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 916 (and cl-list1 cl-list2 (apply 'intersection cl-list1 cl-list2 cl-keys))) |
| 917 | |
|
5067
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
918 ;; XEmacs addition: NOT IN COMMON LISP. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
919 (defun stable-intersection (cl-list1 cl-list2 &rest cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
920 "Stably combine LIST1 and LIST2 using a set-intersection operation. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
921 The result list contains all items that appear in both LIST1 and LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
922 The result is \"stable\" in that it preserves the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
923 LIST1 that are also in LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
924 This is a non-destructive function; it makes a copy of the data if necessary |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
925 to avoid corrupting the original LIST1 and LIST2. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
926 Keywords supported: :test :test-not :key |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
927 See `union' for the meaning of :test, :test-not and :key. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
928 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
929 NOTE: This is *NOT* a function defined by Common Lisp, but an XEmacs |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
930 extension." |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
931 ;; The standard `intersection' doesn't produce a "stable" intersection -- |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
932 ;; it iterates over the second list instead of the first one, and returns |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
933 ;; the values in backwards order. According to the CLTL2 documentation, |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
934 ;; `intersection' is not required to preserve the ordering of elements in |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
935 ;; any fashion, so we add a new function rather than changing the |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
936 ;; semantics of `intersection'. |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
937 (and cl-list1 cl-list2 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
938 (if (equal cl-list1 cl-list2) cl-list1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
939 (cl-parsing-keywords (:key) (:test :test-not) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
940 (loop for cl-l in cl-list1 |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
941 if (if (or cl-keys (numberp cl-l)) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
942 (apply 'member* (cl-check-key cl-l) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
943 cl-list2 cl-keys) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
944 (memq cl-l cl-list2)) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
945 collect cl-l))))) |
|
7d7ae8db0341
add functions `stable-union' and `stable-intersection' to do stable set operations
Ben Wing <ben@xemacs.org>
parents:
5066
diff
changeset
|
946 |
| 428 | 947 (defun set-difference (cl-list1 cl-list2 &rest cl-keys) |
| 948 "Combine LIST1 and LIST2 using a set-difference operation. | |
| 949 The result list contains all items that appear in LIST1 but not LIST2. | |
| 950 This is a non-destructive function; it makes a copy of the data if necessary | |
| 951 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
952 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
953 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 954 (if (or (null cl-list1) (null cl-list2)) cl-list1 |
| 955 (cl-parsing-keywords (:key) (:test :test-not) | |
| 956 (let ((cl-res nil)) | |
| 957 (while cl-list1 | |
| 958 (or (if (or cl-keys (numberp (car cl-list1))) | |
| 959 (apply 'member* (cl-check-key (car cl-list1)) | |
| 960 cl-list2 cl-keys) | |
| 961 (memq (car cl-list1) cl-list2)) | |
| 2153 | 962 (push (car cl-list1) cl-res)) |
| 963 (pop cl-list1)) | |
| 428 | 964 cl-res)))) |
| 965 | |
| 966 (defun nset-difference (cl-list1 cl-list2 &rest cl-keys) | |
| 967 "Combine LIST1 and LIST2 using a set-difference operation. | |
| 968 The result list contains all items that appear in LIST1 but not LIST2. | |
| 969 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 970 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
971 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
972 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 973 (if (or (null cl-list1) (null cl-list2)) cl-list1 |
| 974 (apply 'set-difference cl-list1 cl-list2 cl-keys))) | |
| 975 | |
| 976 (defun set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) | |
| 977 "Combine LIST1 and LIST2 using a set-exclusive-or operation. | |
| 978 The result list contains all items that appear in exactly one of LIST1, LIST2. | |
| 979 This is a non-destructive function; it makes a copy of the data if necessary | |
| 980 to avoid corrupting the original LIST1 and LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
981 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
982 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 983 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 984 ((equal cl-list1 cl-list2) nil) | |
| 985 (t (append (apply 'set-difference cl-list1 cl-list2 cl-keys) | |
| 986 (apply 'set-difference cl-list2 cl-list1 cl-keys))))) | |
| 987 | |
| 988 (defun nset-exclusive-or (cl-list1 cl-list2 &rest cl-keys) | |
| 989 "Combine LIST1 and LIST2 using a set-exclusive-or operation. | |
| 990 The result list contains all items that appear in exactly one of LIST1, LIST2. | |
| 991 This is a destructive function; it reuses the storage of LIST1 and LIST2 | |
| 992 whenever possible. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
993 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
994 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 995 (cond ((null cl-list1) cl-list2) ((null cl-list2) cl-list1) |
| 996 ((equal cl-list1 cl-list2) nil) | |
| 997 (t (nconc (apply 'nset-difference cl-list1 cl-list2 cl-keys) | |
| 998 (apply 'nset-difference cl-list2 cl-list1 cl-keys))))) | |
| 999 | |
| 1000 (defun subsetp (cl-list1 cl-list2 &rest cl-keys) | |
| 1001 "True if LIST1 is a subset of LIST2. | |
| 1002 I.e., if every element of LIST1 also appears in LIST2. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1003 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1004 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 1005 (cond ((null cl-list1) t) ((null cl-list2) nil) |
| 1006 ((equal cl-list1 cl-list2) t) | |
| 1007 (t (cl-parsing-keywords (:key) (:test :test-not) | |
| 1008 (while (and cl-list1 | |
| 1009 (apply 'member* (cl-check-key (car cl-list1)) | |
| 1010 cl-list2 cl-keys)) | |
| 2153 | 1011 (pop cl-list1)) |
| 428 | 1012 (null cl-list1))))) |
| 1013 | |
| 1014 (defun subst-if (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1015 "Substitute NEW for elements matching PREDICATE in TREE (non-destructively). | |
| 1016 Return a copy of TREE with all matching elements replaced by NEW. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1017 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1018 See `member*' for the meaning of :key." |
| 2153 | 1019 (apply 'sublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) |
| 428 | 1020 |
| 1021 (defun subst-if-not (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1022 "Substitute NEW for elts not matching PREDICATE in TREE (non-destructively). | |
| 1023 Return a copy of TREE with all non-matching elements replaced by NEW. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1024 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1025 See `member*' for the meaning of :key." |
| 2153 | 1026 (apply 'sublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) |
| 428 | 1027 |
| 1028 (defun nsubst (cl-new cl-old cl-tree &rest cl-keys) | |
| 1029 "Substitute NEW for OLD everywhere in TREE (destructively). | |
| 1030 Any element of TREE which is `eql' to OLD is changed to NEW (via a call | |
| 1031 to `setcar'). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1032 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1033 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 1034 (apply 'nsublis (list (cons cl-old cl-new)) cl-tree cl-keys)) |
| 1035 | |
| 1036 (defun nsubst-if (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1037 "Substitute NEW for elements matching PREDICATE in TREE (destructively). | |
| 1038 Any element of TREE which matches is changed to NEW (via a call to `setcar'). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1039 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1040 See `member*' for the meaning of :key." |
| 2153 | 1041 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if cl-pred cl-keys)) |
| 428 | 1042 |
| 1043 (defun nsubst-if-not (cl-new cl-pred cl-tree &rest cl-keys) | |
| 1044 "Substitute NEW for elements not matching PREDICATE in TREE (destructively). | |
| 1045 Any element of TREE which matches is changed to NEW (via a call to `setcar'). | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1046 Keywords supported: :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1047 See `member*' for the meaning of :key." |
| 2153 | 1048 (apply 'nsublis (list (cons nil cl-new)) cl-tree :if-not cl-pred cl-keys)) |
| 428 | 1049 |
| 1050 (defun sublis (cl-alist cl-tree &rest cl-keys) | |
| 1051 "Perform substitutions indicated by ALIST in TREE (non-destructively). | |
| 1052 Return a copy of TREE with all matching elements replaced. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1053 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1054 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 1055 (cl-parsing-keywords (:test :test-not :key :if :if-not) () |
| 1056 (cl-sublis-rec cl-tree))) | |
| 1057 | |
| 1058 (defvar cl-alist) | |
| 1059 (defun cl-sublis-rec (cl-tree) ; uses cl-alist/key/test*/if* | |
| 1060 (let ((cl-temp (cl-check-key cl-tree)) (cl-p cl-alist)) | |
| 1061 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
| 1062 (setq cl-p (cdr cl-p))) | |
| 1063 (if cl-p (cdr (car cl-p)) | |
| 1064 (if (consp cl-tree) | |
| 1065 (let ((cl-a (cl-sublis-rec (car cl-tree))) | |
| 1066 (cl-d (cl-sublis-rec (cdr cl-tree)))) | |
| 1067 (if (and (eq cl-a (car cl-tree)) (eq cl-d (cdr cl-tree))) | |
| 1068 cl-tree | |
| 1069 (cons cl-a cl-d))) | |
| 1070 cl-tree)))) | |
| 1071 | |
| 1072 (defun nsublis (cl-alist cl-tree &rest cl-keys) | |
| 1073 "Perform substitutions indicated by ALIST in TREE (destructively). | |
| 1074 Any matching element of TREE is changed via a call to `setcar'. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1075 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1076 See `member*' for the meaning of :test, :test-not and :key." |
| 428 | 1077 (cl-parsing-keywords (:test :test-not :key :if :if-not) () |
| 1078 (let ((cl-hold (list cl-tree))) | |
| 1079 (cl-nsublis-rec cl-hold) | |
| 1080 (car cl-hold)))) | |
| 1081 | |
| 1082 (defun cl-nsublis-rec (cl-tree) ; uses cl-alist/temp/p/key/test*/if* | |
| 1083 (while (consp cl-tree) | |
| 1084 (let ((cl-temp (cl-check-key (car cl-tree))) (cl-p cl-alist)) | |
| 1085 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
| 1086 (setq cl-p (cdr cl-p))) | |
| 1087 (if cl-p (setcar cl-tree (cdr (car cl-p))) | |
| 1088 (if (consp (car cl-tree)) (cl-nsublis-rec (car cl-tree)))) | |
| 1089 (setq cl-temp (cl-check-key (cdr cl-tree)) cl-p cl-alist) | |
| 1090 (while (and cl-p (not (cl-check-test-nokey (car (car cl-p)) cl-temp))) | |
| 1091 (setq cl-p (cdr cl-p))) | |
| 1092 (if cl-p | |
| 1093 (progn (setcdr cl-tree (cdr (car cl-p))) (setq cl-tree nil)) | |
| 1094 (setq cl-tree (cdr cl-tree)))))) | |
| 1095 | |
| 1096 (defun tree-equal (cl-x cl-y &rest cl-keys) | |
| 1097 "Return t if trees X and Y have `eql' leaves. | |
| 1098 Atoms are compared by `eql'; cons cells are compared recursively. | |
|
5066
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1099 Keywords supported: :test :test-not :key |
|
545ec923b4eb
add documentation on keywords to cl*.el
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
1100 See `union' for the meaning of :test, :test-not and :key." |
| 428 | 1101 (cl-parsing-keywords (:test :test-not :key) () |
| 1102 (cl-tree-equal-rec cl-x cl-y))) | |
| 1103 | |
| 1104 (defun cl-tree-equal-rec (cl-x cl-y) | |
| 1105 (while (and (consp cl-x) (consp cl-y) | |
| 1106 (cl-tree-equal-rec (car cl-x) (car cl-y))) | |
| 1107 (setq cl-x (cdr cl-x) cl-y (cdr cl-y))) | |
| 1108 (and (not (consp cl-x)) (not (consp cl-y)) (cl-check-match cl-x cl-y))) | |
| 1109 | |
| 1110 | |
| 1111 (run-hooks 'cl-seq-load-hook) | |
| 1112 | |
| 2153 | 1113 ;;; arch-tag: ec1cc072-9006-4225-b6ba-d6b07ed1710c |
| 428 | 1114 ;;; cl-seq.el ends here |