1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | (in-package "CCL") |
---|
19 | |
---|
20 | (eval-when (eval compile) |
---|
21 | (require 'backquote) |
---|
22 | (require 'level-2)) |
---|
23 | |
---|
24 | (defun caaaar (list) (car (caaar list))) |
---|
25 | (defun caaadr (list) (car (caadr list))) |
---|
26 | (defun caadar (list) (car (cadar list))) |
---|
27 | (defun caaddr (list) (car (caddr list))) |
---|
28 | (defun cadaar (list) (car (cdaar list))) |
---|
29 | (defun cadadr (list) (car (cdadr list))) |
---|
30 | (defun caddar (list) (car (cddar list))) |
---|
31 | (defun cadddr (list) (car (cdddr list))) |
---|
32 | (defun cdaaar (list) (cdr (caaar list))) |
---|
33 | (defun cdaadr (list) (cdr (caadr list))) |
---|
34 | (defun cdadar (list) (cdr (cadar list))) |
---|
35 | (defun cdaddr (list) (cdr (caddr list))) |
---|
36 | (defun cddaar (list) (cdr (cdaar list))) |
---|
37 | (defun cddadr (list) (cdr (cdadr list))) |
---|
38 | (defun cdddar (list) (cdr (cddar list))) |
---|
39 | (defun cddddr (list) (cdr (cdddr list))) |
---|
40 | |
---|
41 | (defun tree-equal (x y &key (test (function eql)) test-not) |
---|
42 | "Returns T if X and Y are isomorphic trees with identical leaves." |
---|
43 | (if test-not |
---|
44 | (tree-equal-test-not x y test-not) |
---|
45 | (tree-equal-test x y test))) |
---|
46 | |
---|
47 | (defun tree-equal-test-not (x y test-not) |
---|
48 | (cond ((and (atom x) (atom y)) |
---|
49 | (if (and (not x) (not y)) ;must special case end of both lists. |
---|
50 | t |
---|
51 | (if (not (funcall test-not x y)) t))) |
---|
52 | ((consp x) |
---|
53 | (and (consp y) |
---|
54 | (tree-equal-test-not (car x) (car y) test-not) |
---|
55 | (tree-equal-test-not (cdr x) (cdr y) test-not))) |
---|
56 | (t ()))) |
---|
57 | |
---|
58 | (defun tree-equal-test (x y test) |
---|
59 | (if (atom x) |
---|
60 | (if (atom y) |
---|
61 | (if (funcall test x y) t)) |
---|
62 | (and (consp y) |
---|
63 | (tree-equal-test (car x) (car y) test) |
---|
64 | (tree-equal-test (cdr x) (cdr y) test)))) |
---|
65 | |
---|
66 | (defun first (list) |
---|
67 | "Return the 1st object in a list or NIL if the list is empty." |
---|
68 | (car list)) |
---|
69 | |
---|
70 | (defun second (list) |
---|
71 | "Return the 2nd object in a list or NIL if there is no 2nd object." |
---|
72 | (cadr list)) |
---|
73 | |
---|
74 | (defun third (list) |
---|
75 | "Return the 3rd object in a list or NIL if there is no 3rd object." |
---|
76 | (caddr list)) |
---|
77 | |
---|
78 | (defun fourth (list) |
---|
79 | "Return the 4th object in a list or NIL if there is no 4th object." |
---|
80 | (cadddr list)) |
---|
81 | |
---|
82 | (defun fifth (list) |
---|
83 | "Return the 5th object in a list or NIL if there is no 5th object." |
---|
84 | (car (cddddr list))) |
---|
85 | |
---|
86 | (defun sixth (list) |
---|
87 | "Return the 6th object in a list or NIL if there is no 6th object." |
---|
88 | (cadr (cddddr list))) |
---|
89 | |
---|
90 | (defun seventh (list) |
---|
91 | "Return the 7th object in a list or NIL if there is no 7th object." |
---|
92 | (caddr (cddddr list))) |
---|
93 | |
---|
94 | (defun eighth (list) |
---|
95 | "Return the 8th object in a list or NIL if there is no 8th object." |
---|
96 | (cadddr (cddddr list))) |
---|
97 | |
---|
98 | (defun ninth (list) |
---|
99 | "Return the 9th object in a list or NIL if there is no 9th object." |
---|
100 | (car (cddddr (cddddr list)))) |
---|
101 | |
---|
102 | (defun tenth (list) |
---|
103 | "Return the 10th object in a list or NIL if there is no 10th object." |
---|
104 | (cadr (cddddr (cddddr list)))) |
---|
105 | |
---|
106 | (defun rest (list) |
---|
107 | "Means the same as the cdr of a list." |
---|
108 | (cdr list)) |
---|
109 | ;;; List* is done the same as list, except that the last cons is made a |
---|
110 | ;;; dotted pair |
---|
111 | |
---|
112 | |
---|
113 | ;;; List Copying Functions |
---|
114 | |
---|
115 | ;;; The list is copied correctly even if the list is not terminated by () |
---|
116 | ;;; The new list is built by cdr'ing splice which is always at the tail |
---|
117 | ;;; of the new list |
---|
118 | |
---|
119 | |
---|
120 | (defun copy-alist (alist) |
---|
121 | "Return a new association list which is EQUAL to ALIST." |
---|
122 | (unless (endp alist) |
---|
123 | (let ((result |
---|
124 | (cons (if (endp (car alist)) |
---|
125 | (car alist) |
---|
126 | (cons (caar alist) (cdar alist)) ) |
---|
127 | '() ))) |
---|
128 | (do ((x (cdr alist) (cdr x)) |
---|
129 | (splice result |
---|
130 | (cdr (rplacd splice |
---|
131 | (cons |
---|
132 | (if (endp (car x)) |
---|
133 | (car x) |
---|
134 | (cons (caar x) (cdar x))) |
---|
135 | '() ))) )) |
---|
136 | ((endp x) result))))) |
---|
137 | |
---|
138 | ;;; More Commonly-used List Functions |
---|
139 | |
---|
140 | (defun revappend (x y) |
---|
141 | "Return (append (reverse x) y)." |
---|
142 | (dolist (a x y) (push a y))) |
---|
143 | |
---|
144 | |
---|
145 | |
---|
146 | |
---|
147 | (defun butlast (list &optional (n 1 n-p)) |
---|
148 | "Returns a new list the same as List without the N last elements." |
---|
149 | (setq list (require-type list 'list)) |
---|
150 | (when (and n-p |
---|
151 | (if (typep n 'fixnum) |
---|
152 | (< (the fixnum n) 0) |
---|
153 | (not (typep n 'unsigned-byte)))) |
---|
154 | (report-bad-arg n 'unsigned-byte)) |
---|
155 | (let* ((length (alt-list-length list))) |
---|
156 | (declare (fixnum length)) ;guaranteed |
---|
157 | (when (< n length) |
---|
158 | (let* ((count (- length (the fixnum n))) |
---|
159 | (head (cons nil nil)) |
---|
160 | (tail head)) |
---|
161 | (declare (fixnum count) (cons head tail) (dynamic-extent head)) |
---|
162 | ;; Return a list of the first COUNT elements of list |
---|
163 | (dotimes (i count (cdr head)) |
---|
164 | (setq tail (cdr (rplacd tail (cons (pop list) nil))))))))) |
---|
165 | |
---|
166 | |
---|
167 | (defun nbutlast (list &optional (n 1 n-p)) |
---|
168 | "Modifies List to remove the last N elements." |
---|
169 | (setq list (require-type list 'list)) |
---|
170 | (when (and n-p |
---|
171 | (if (typep n 'fixnum) |
---|
172 | (< (the fixnum n) 0) |
---|
173 | (not (typep n 'unsigned-byte)))) |
---|
174 | (report-bad-arg n 'unsigned-byte)) |
---|
175 | (let* ((length (alt-list-length list))) |
---|
176 | (declare (fixnum length)) ;guaranteed |
---|
177 | (when (< n length) |
---|
178 | (let* ((count (1- (the fixnum (- length (the fixnum n))))) |
---|
179 | (tail list)) |
---|
180 | (declare (fixnum count) (list tail)) |
---|
181 | (dotimes (i count (rplacd tail nil)) |
---|
182 | (setq tail (cdr tail))) |
---|
183 | list)))) |
---|
184 | |
---|
185 | |
---|
186 | (defun ldiff (list object) |
---|
187 | "Return a new list, whose elements are those of LIST that appear before |
---|
188 | OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned. |
---|
189 | LIST must be a proper list or a dotted list." |
---|
190 | (do* ((list (require-type list 'list) (cdr list)) |
---|
191 | (result (cons nil nil)) |
---|
192 | (splice result)) |
---|
193 | ((atom list) |
---|
194 | (if (eql list object) |
---|
195 | (cdr result) |
---|
196 | (progn (rplacd splice list) (cdr result)))) |
---|
197 | (declare (dynamic-extent result) |
---|
198 | (cons splice result)) |
---|
199 | (if (eql list object) |
---|
200 | (return (cdr result)) |
---|
201 | (setq splice (cdr (rplacd splice (list (car list)))))))) |
---|
202 | |
---|
203 | |
---|
204 | ;;; Functions to alter list structure |
---|
205 | |
---|
206 | ;;; The following are for use by SETF. |
---|
207 | |
---|
208 | (defun %setnth (n list newval) |
---|
209 | "Sets the Nth element of List (zero based) to Newval." |
---|
210 | (if (%i< n 0) |
---|
211 | (error "~S is an illegal N for SETF of NTH." n) |
---|
212 | (do ((count n (%i- count 1))) |
---|
213 | ((%izerop count) (rplaca list newval) newval) |
---|
214 | (if (endp (cdr list)) |
---|
215 | (error "~S is too large an index for SETF of NTH." n) |
---|
216 | (setq list (cdr list)))))) |
---|
217 | |
---|
218 | (defun test-not-error (test test-not) |
---|
219 | (%err-disp $xkeyconflict :test test :test-not test-not)) |
---|
220 | |
---|
221 | ;;; Use this with the following keyword args: |
---|
222 | ;;; (&key (key #'identity) (test #'eql testp) (test-not nil notp)) |
---|
223 | |
---|
224 | (eval-when (eval compile #-bccl load) |
---|
225 | (defmacro with-set-keys (funcall) |
---|
226 | `(cond (notp ,(append funcall '(:key key :test-not test-not))) |
---|
227 | (t ,(append funcall '(:key key :test test))))) |
---|
228 | |
---|
229 | ;;; Works with the above keylist. We do three clauses so that if only test-not |
---|
230 | ;;; is supplied, then we don't test eql. In each case, the args should be |
---|
231 | ;;; multiply evaluable. |
---|
232 | |
---|
233 | (defmacro elements-match-p (elt1 elt2) |
---|
234 | `(or (and testp |
---|
235 | (funcall test (funcall key ,elt1) (funcall key ,elt2))) |
---|
236 | (and notp |
---|
237 | (not (funcall test-not (funcall key ,elt1) (funcall key ,elt2)))) |
---|
238 | (eql (funcall key ,elt1) (funcall key ,elt2)))) |
---|
239 | |
---|
240 | |
---|
241 | |
---|
242 | ) |
---|
243 | ;;; Substitution of expressions |
---|
244 | |
---|
245 | ;subst that doesn't call labels |
---|
246 | (defun subst (new old tree &key key |
---|
247 | (test #'eql testp) (test-not nil notp)) |
---|
248 | "Substitutes new for subtrees matching old." |
---|
249 | (if (and testp notp) |
---|
250 | (test-not-error test test-not)) |
---|
251 | (subst-aux new old tree key test test-not)) |
---|
252 | |
---|
253 | (defun subst-aux (new old subtree key test test-not) |
---|
254 | (flet ((satisfies-the-test (item elt) |
---|
255 | (let* ((val (if key (funcall key elt) elt))) |
---|
256 | (if test-not |
---|
257 | (not (funcall test-not item val)) |
---|
258 | (funcall test item val))))) |
---|
259 | (declare (inline satisfies-the-test)) |
---|
260 | (cond ((satisfies-the-test old subtree) new) |
---|
261 | ((atom subtree) subtree) |
---|
262 | (t (let ((car (subst-aux new old (car subtree) |
---|
263 | key test test-not )) |
---|
264 | (cdr (subst-aux new old (cdr subtree) |
---|
265 | key test test-not))) |
---|
266 | (if (and (eq car (car subtree)) |
---|
267 | (eq cdr (cdr subtree))) |
---|
268 | subtree |
---|
269 | (cons car cdr))))))) |
---|
270 | |
---|
271 | ;;;subst-if without a call to labels |
---|
272 | ;;; I've always wondered how those calls to a special operator |
---|
273 | ;;; should best be avoided. Clearly, the answer involves |
---|
274 | ;;; lots of recursion. |
---|
275 | (defun subst-if (new test tree &key key) |
---|
276 | "Substitutes new for subtrees for which test is true." |
---|
277 | (unless key (setq key #'identity)) |
---|
278 | (cond ((funcall test (funcall key tree)) new) |
---|
279 | ((atom tree) tree) |
---|
280 | (t (let ((car (subst-if new test (car tree) :key key)) |
---|
281 | (cdr (subst-if new test (cdr tree) :key key))) |
---|
282 | (if (and (eq car (car tree)) |
---|
283 | (eq cdr (cdr tree))) |
---|
284 | tree |
---|
285 | (cons car cdr)))))) |
---|
286 | |
---|
287 | ;subst-if-not without a call to labels |
---|
288 | (defun subst-if-not (new test tree &key key) |
---|
289 | "Substitutes new for subtrees for which test is false." |
---|
290 | (unless key (setq key #'identity)) |
---|
291 | (cond ((not (funcall test (funcall key tree))) new) |
---|
292 | ((atom tree) tree) |
---|
293 | (t (let ((car (subst-if-not new test (car tree) :key key)) |
---|
294 | (cdr (subst-if-not new test (cdr tree) :key key))) |
---|
295 | (if (and (eq car (car tree)) |
---|
296 | (eq cdr (cdr tree))) |
---|
297 | tree |
---|
298 | (cons car cdr)))))) |
---|
299 | |
---|
300 | (defun nsubst (new old tree &key key |
---|
301 | (test #'eql testp) (test-not nil notp)) |
---|
302 | "Substitute NEW for subtrees matching OLD." |
---|
303 | (if (and testp notp) |
---|
304 | (test-not-error test test-not)) |
---|
305 | (nsubst-aux new old tree (or key #'identity) test test-not)) |
---|
306 | |
---|
307 | (defun nsubst-aux (new old subtree key test test-not) |
---|
308 | (flet ((satisfies-the-test (item elt) |
---|
309 | (let* ((val (if key (funcall key elt) elt))) |
---|
310 | (if test-not |
---|
311 | (not (funcall test-not item val)) |
---|
312 | (funcall test item val))))) |
---|
313 | (declare (inline satisfies-the-test)) |
---|
314 | (cond ((satisfies-the-test old subtree) new) |
---|
315 | ((atom subtree) subtree) |
---|
316 | (t (do* ((last nil subtree) |
---|
317 | (subtree subtree (cdr subtree))) |
---|
318 | ((atom subtree) |
---|
319 | (if (satisfies-the-test old subtree) |
---|
320 | (set-cdr last new))) |
---|
321 | (if (satisfies-the-test old subtree) |
---|
322 | (return (set-cdr last new)) |
---|
323 | (set-car subtree |
---|
324 | (nsubst-aux new old (car subtree) |
---|
325 | key test test-not)))) |
---|
326 | subtree)))) |
---|
327 | |
---|
328 | (defun nsubst-if (new test tree &key key) |
---|
329 | "Substitute NEW for subtrees of TREE for which TEST is true." |
---|
330 | (unless key (setq key #'identity)) |
---|
331 | (cond ((funcall test (funcall key tree)) new) |
---|
332 | ((atom tree) tree) |
---|
333 | (t (do* ((last nil tree) |
---|
334 | (tree tree (cdr tree))) |
---|
335 | ((atom tree) |
---|
336 | (if (funcall test (funcall key tree)) |
---|
337 | (set-cdr last new))) |
---|
338 | (if (funcall test (funcall key tree)) |
---|
339 | (return (set-cdr last new)) |
---|
340 | (set-car tree |
---|
341 | (nsubst-if new test (car tree) :key key)))) |
---|
342 | tree))) |
---|
343 | |
---|
344 | (defun nsubst-if-not (new test tree &key key) |
---|
345 | "Substitute NEW for subtrees of TREE for which TEST is false." |
---|
346 | (unless key (setq key #'identity)) |
---|
347 | (cond ((not (funcall test (funcall key tree))) new) |
---|
348 | ((atom tree) tree) |
---|
349 | (t (do* ((last nil tree) |
---|
350 | (tree tree (cdr tree))) |
---|
351 | ((atom tree) |
---|
352 | (if (not (funcall test (funcall key tree))) |
---|
353 | (set-cdr last new))) |
---|
354 | (if (not (funcall test (funcall key tree))) |
---|
355 | (return (set-cdr (cdr last) new)) |
---|
356 | (set-car tree |
---|
357 | (nsubst-if-not new test (car tree) :key key)))) |
---|
358 | tree))) |
---|
359 | |
---|
360 | (defun sublis (alist tree &key key |
---|
361 | (test #'eql testp) (test-not nil notp)) |
---|
362 | "Substitute from ALIST into TREE nondestructively." |
---|
363 | (if (and testp notp) |
---|
364 | (test-not-error test test-not)) |
---|
365 | (sublis-aux alist tree (or key #'identity) test test-not notp)) |
---|
366 | |
---|
367 | (defun sublis-aux (alist subtree key test test-not notp) |
---|
368 | (let ((assoc (if notp |
---|
369 | (assoc (funcall key subtree) alist :test-not test-not) |
---|
370 | (assoc (funcall key subtree) alist :test test)))) |
---|
371 | (cond (assoc (cdr assoc)) |
---|
372 | ((atom subtree) subtree) |
---|
373 | (t (let ((car (sublis-aux alist (car subtree) |
---|
374 | key test test-not notp)) |
---|
375 | (cdr (sublis-aux alist (cdr subtree) |
---|
376 | key test test-not notp))) |
---|
377 | (if (and (eq car (car subtree)) |
---|
378 | (eq cdr (cdr subtree))) |
---|
379 | subtree |
---|
380 | (cons car cdr))))))) |
---|
381 | |
---|
382 | (eval-when (compile eval) |
---|
383 | (defmacro nsublis-macro () |
---|
384 | '(if notp |
---|
385 | (assoc (funcall key subtree) alist :test-not test-not) |
---|
386 | (assoc (funcall key subtree) alist :test test))) |
---|
387 | ) |
---|
388 | |
---|
389 | (defun nsublis (alist tree &key key |
---|
390 | (test #'eql testp) (test-not nil notp)) |
---|
391 | "Substitute from ALIST into TRUE destructively." |
---|
392 | (if (and testp notp) |
---|
393 | (test-not-error test test-not)) |
---|
394 | (nsublis-aux alist tree (or key #'identity) test test-not notp)) |
---|
395 | |
---|
396 | (defun nsublis-aux (alist subtree key test test-not notp &optional temp) |
---|
397 | (cond ((setq temp (nsublis-macro)) |
---|
398 | (cdr temp)) |
---|
399 | ((atom subtree) subtree) |
---|
400 | (t (do* ((last nil subtree) |
---|
401 | (subtree subtree (cdr subtree))) |
---|
402 | ((atom subtree) |
---|
403 | (if (setq temp (nsublis-macro)) |
---|
404 | (set-cdr last (cdr temp)))) |
---|
405 | (if (setq temp (nsublis-macro)) |
---|
406 | (return (set-cdr last (cdr temp))) |
---|
407 | (set-car subtree |
---|
408 | (nsublis-aux alist (car subtree) key test |
---|
409 | test-not notp temp)))) |
---|
410 | subtree))) |
---|
411 | |
---|
412 | ;;; Functions for using lists as sets |
---|
413 | |
---|
414 | |
---|
415 | (defun member-if (test list &key key ) |
---|
416 | "Return tail of LIST beginning with first element satisfying TEST." |
---|
417 | (unless key (setq key #'identity)) |
---|
418 | (do ((list list (Cdr list))) |
---|
419 | ((endp list) nil) |
---|
420 | (if (funcall test (funcall key (car list))) |
---|
421 | (return list)))) |
---|
422 | |
---|
423 | (defun member-if-not (test list &key key) |
---|
424 | "Return tail of LIST beginning with first element not satisfying TEST." |
---|
425 | (unless key (setq key #'identity)) |
---|
426 | (do ((list list (cdr list))) |
---|
427 | ((endp list) ()) |
---|
428 | (if (not (funcall test (funcall key (car list)))) |
---|
429 | (return list)))) |
---|
430 | |
---|
431 | (defun tailp (sublist list) ;Definition "B" |
---|
432 | "Return true if OBJECT is the same as some tail of LIST, otherwise |
---|
433 | returns false. LIST must be a proper list or a dotted list." |
---|
434 | (do ((list list (%cdr list))) |
---|
435 | ((atom list) (eql list sublist)) |
---|
436 | (if (eq sublist list) |
---|
437 | (return t)))) |
---|
438 | |
---|
439 | |
---|
440 | |
---|
441 | (defun union (list1 list2 &key |
---|
442 | key |
---|
443 | (test #'eql testp) |
---|
444 | (test-not nil notp)) |
---|
445 | "Returns the union of LIST1 and LIST2." |
---|
446 | (if (and testp notp) |
---|
447 | (test-not-error test test-not)) |
---|
448 | (unless key (setq key #'identity)) |
---|
449 | (let ((res list2)) |
---|
450 | (dolist (elt list1) |
---|
451 | (if (not (with-set-keys (member (funcall key elt) list2))) |
---|
452 | (push elt res))) |
---|
453 | res)) |
---|
454 | |
---|
455 | |
---|
456 | |
---|
457 | |
---|
458 | |
---|
459 | |
---|
460 | (eval-when (eval compile #-bccl load) |
---|
461 | ;;; Destination and source are setf-able and many-evaluable. |
---|
462 | ;;; Sets the source to the cdr, and "conses" the 1st elt of |
---|
463 | ;;; source to destination. |
---|
464 | (defmacro steve-splice (source destination) |
---|
465 | `(let ((temp ,source)) |
---|
466 | (setf ,source (cdr ,source) |
---|
467 | (cdr temp) ,destination |
---|
468 | ,destination temp))) |
---|
469 | ) |
---|
470 | |
---|
471 | (defun nunion (list1 list2 &key key |
---|
472 | (test #'eql testp) (test-not nil notp)) |
---|
473 | "Destructively return the union of LIST1 and LIST2." |
---|
474 | (if (and testp notp) |
---|
475 | (test-not-error test test-not)) |
---|
476 | (unless key (setq key #'identity)) |
---|
477 | (let ((res list2)) |
---|
478 | (do () |
---|
479 | ((endp list1)) |
---|
480 | (if (not (with-set-keys (member (funcall key (car list1)) list2))) |
---|
481 | (steve-splice list1 res) |
---|
482 | (setq list1 (cdr list1)))) |
---|
483 | res)) |
---|
484 | |
---|
485 | |
---|
486 | |
---|
487 | |
---|
488 | (defun intersection (list1 list2 &key key |
---|
489 | (test #'eql testp) (test-not nil notp)) |
---|
490 | "Return the intersection of LIST1 and LIST2." |
---|
491 | (if (and testp notp) |
---|
492 | (test-not-error test test-not)) |
---|
493 | (unless key (setq key #'identity)) |
---|
494 | (let ((res nil)) |
---|
495 | (dolist (elt list1) |
---|
496 | (if (with-set-keys (member (funcall key elt) list2)) |
---|
497 | (push elt res))) |
---|
498 | res)) |
---|
499 | |
---|
500 | (defun nintersection (list1 list2 &key key |
---|
501 | (test #'eql testp) (test-not nil notp)) |
---|
502 | "Destructively return the intersection of LIST1 and LIST2." |
---|
503 | (if (and testp notp) |
---|
504 | (test-not-error test test-not)) |
---|
505 | (unless key (setq key #'identity)) |
---|
506 | (let ((res nil)) |
---|
507 | (do () ((endp list1)) |
---|
508 | (if (with-set-keys (member (funcall key (car list1)) list2)) |
---|
509 | (steve-splice list1 res) |
---|
510 | (setq list1 (Cdr list1)))) |
---|
511 | res)) |
---|
512 | |
---|
513 | (defun set-difference (list1 list2 &key key |
---|
514 | (test #'eql testp) (test-not nil notp)) |
---|
515 | "Return the elements of LIST1 which are not in LIST2." |
---|
516 | (if (and testp notp) |
---|
517 | (test-not-error test test-not)) |
---|
518 | (unless key (setq key #'identity)) |
---|
519 | (let ((res nil)) |
---|
520 | (dolist (elt list1) |
---|
521 | (if (not (with-set-keys (member (funcall key elt) list2))) |
---|
522 | (push elt res))) |
---|
523 | res)) |
---|
524 | |
---|
525 | (defun nset-difference (list1 list2 &key key |
---|
526 | (test #'eql testp) (test-not nil notp)) |
---|
527 | "Destructively return the elements of LIST1 which are not in LIST2." |
---|
528 | (if (and testp notp) |
---|
529 | (test-not-error test test-not)) |
---|
530 | (unless key (setq key #'identity)) |
---|
531 | (let ((res nil)) |
---|
532 | (do () ((endp list1)) |
---|
533 | (if (not (with-set-keys (member (funcall key (car list1)) list2))) |
---|
534 | (steve-splice list1 res) |
---|
535 | (setq list1 (cdr list1)))) |
---|
536 | res)) |
---|
537 | |
---|
538 | #| spice version |
---|
539 | (defun set-exclusive-or (list1 list2 &key (key #'identity) |
---|
540 | (test #'eql testp) (test-not nil notp)) |
---|
541 | "Returns new list of elements appearing exactly once in List1 and List2. |
---|
542 | If an element appears > once in a list and does not appear at all in the |
---|
543 | other list, that element will appear >1 in the output list." |
---|
544 | (let ((result nil)) |
---|
545 | (dolist (elt list1) |
---|
546 | (unless (with-set-keys (member (funcall key elt) list2)) |
---|
547 | (setq result (cons elt result)))) |
---|
548 | (dolist (elt list2) |
---|
549 | (unless (with-set-keys (member (funcall key elt) list1)) |
---|
550 | (setq result (cons elt result)))) |
---|
551 | result)) |
---|
552 | |# |
---|
553 | |
---|
554 | (defun set-exclusive-or (list1 list2 &key key |
---|
555 | (test #'eql testp) (test-not nil notp) |
---|
556 | &aux result elt1-compare elt2-compare) |
---|
557 | "Return new list of elements appearing exactly once in LIST1 and LIST2." |
---|
558 | (if (and testp notp) |
---|
559 | (test-not-error test test-not)) |
---|
560 | (unless key (setq key #'identity)) |
---|
561 | (dolist (elt1 list1) |
---|
562 | (setq elt1-compare (funcall key elt1)) |
---|
563 | (if (if notp |
---|
564 | (dolist (elt2 list2 t) |
---|
565 | (if (not (funcall test-not elt1-compare (funcall key elt2))) |
---|
566 | (return nil))) |
---|
567 | (dolist (elt2 list2 t) |
---|
568 | (if (funcall test elt1-compare (funcall key elt2)) |
---|
569 | (return nil)))) |
---|
570 | (push elt1 result))) |
---|
571 | (dolist (elt2 list2) |
---|
572 | (setq elt2-compare (funcall key elt2)) |
---|
573 | (if (if notp |
---|
574 | (dolist (elt1 list1 t) |
---|
575 | (if (not (funcall test-not (funcall key elt1) elt2-compare)) |
---|
576 | (return nil))) |
---|
577 | (dolist (elt1 list1 t) |
---|
578 | (if (funcall test (funcall key elt1) elt2-compare) |
---|
579 | (return nil)))) |
---|
580 | (push elt2 result))) |
---|
581 | result) |
---|
582 | |
---|
583 | #| the description of the below SpiceLisp algorthm used for implementing |
---|
584 | nset-exclusive-or sounds counter to CLtL. Furthermore, it fails |
---|
585 | on the example (nset-exclusive-or (list 1 1) (list 1)) |
---|
586 | [returns (1) but should return NIL.] ... fry |
---|
587 | |
---|
588 | ;;; The outer loop examines list1 while the inner loop examines list2. If an |
---|
589 | ;;; element is found in list2 "equal" to the element in list1, both are |
---|
590 | ;;; spliced out. When the end of list1 is reached, what is left of list2 is |
---|
591 | ;;; tacked onto what is left of list1. The splicing operation ensures that |
---|
592 | ;;; the correct operation is performed depending on whether splice is at the |
---|
593 | ;;; top of the list or not |
---|
594 | |
---|
595 | (defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) |
---|
596 | (key #'identity)) |
---|
597 | "Return a list with elements which appear but once in List1 and List2." |
---|
598 | (do ((x list1 (cdr x)) |
---|
599 | (splicex ())) |
---|
600 | ((endp x) |
---|
601 | (if (null splicex) |
---|
602 | (setq list1 list2) |
---|
603 | (rplacd splicex list2)) |
---|
604 | list1) |
---|
605 | (do ((y list2 (cdr y)) |
---|
606 | (splicey ())) |
---|
607 | ((endp y) (setq splicex x)) |
---|
608 | (cond ((if notp |
---|
609 | (not (funcall test-not (funcall key (car x)) |
---|
610 | (funcall key (car y)))) |
---|
611 | (funcall test (funcall key (car x)) |
---|
612 | (funcall key (car y)))) |
---|
613 | (if (null splicex) |
---|
614 | (setq list1 (cdr x)) |
---|
615 | (rplacd splicex (cdr x))) |
---|
616 | (if (null splicey) |
---|
617 | (setq list2 (cdr y)) |
---|
618 | (rplacd splicey (cdr y))) |
---|
619 | (return ())) ; assume lists are really sets |
---|
620 | (t (setq splicey y)))))) |
---|
621 | |# |
---|
622 | |
---|
623 | (defun nset-exclusive-or (list1 list2 &key key |
---|
624 | (test #'eql testp) (test-not nil notp)) |
---|
625 | "Destructively return a list with elements which appear but once in LIST1 |
---|
626 | and LIST2." |
---|
627 | (if (and testp notp) |
---|
628 | (test-not-error test test-not)) |
---|
629 | (unless key (setq key #'identity)) |
---|
630 | (if notp |
---|
631 | (set-exclusive-or list1 list2 :key key :test-not test-not) |
---|
632 | (set-exclusive-or list1 list2 :key key :test test) |
---|
633 | )) |
---|
634 | |
---|
635 | (defun subsetp (list1 list2 &key key |
---|
636 | (test #'eql testp) (test-not nil notp)) |
---|
637 | "Return T if every element in LIST1 is also in LIST2." |
---|
638 | (if (and testp notp) |
---|
639 | (test-not-error test test-not)) |
---|
640 | (unless key (setq key #'identity)) |
---|
641 | (dolist (elt list1) |
---|
642 | (unless (with-set-keys (member (funcall key elt) list2)) |
---|
643 | (return-from subsetp nil))) |
---|
644 | T) |
---|
645 | |
---|
646 | |
---|
647 | ;;; Functions that operate on association lists |
---|
648 | |
---|
649 | (defun acons (key datum a-list) |
---|
650 | "Construct a new alist by adding the pair (KEY . DATUM) to ALIST." |
---|
651 | (cons (cons key datum) a-list)) |
---|
652 | |
---|
653 | (defun pairlis (keys data &optional (alist '())) |
---|
654 | "Construct an association list from KEYS and DATA (adding to ALIST)." |
---|
655 | (do ((x keys (cdr x)) |
---|
656 | (y data (cdr y))) |
---|
657 | ((and (endp x) (endp y)) alist) |
---|
658 | (if (or (endp x) (endp y)) |
---|
659 | (error "The lists of keys and data are of unequal length.")) |
---|
660 | (setq alist (acons (car x) (car y) alist)))) |
---|
661 | |
---|
662 | (defun default-identity-key (key) |
---|
663 | (and key (neq key 'identity) (neq key #'identity) (coerce-to-function key))) |
---|
664 | |
---|
665 | (defun assoc-if (predicate alist &key key) |
---|
666 | "Return the first cons in ALIST whose CAR satisfies PREDICATE. If |
---|
667 | KEY is supplied, apply it to the CAR of each cons before testing." |
---|
668 | (setq key (default-identity-key key)) |
---|
669 | (dolist (pair alist) |
---|
670 | (when (and pair |
---|
671 | (funcall predicate |
---|
672 | (if key (funcall key (car pair)) |
---|
673 | (car pair)))) |
---|
674 | (return pair)))) |
---|
675 | |
---|
676 | (defun assoc-if-not (predicate alist &key key) |
---|
677 | "Return the first cons in ALIST whose CAR does not satisfy PREDICATE. |
---|
678 | If KEY is supplied, apply it to the CAR of each cons before testing." |
---|
679 | (setq key (default-identity-key key)) |
---|
680 | (dolist (pair alist) |
---|
681 | (when (and pair |
---|
682 | (not (funcall predicate |
---|
683 | (if key (funcall key (car pair)) |
---|
684 | (car pair))))) |
---|
685 | (return pair)))) |
---|
686 | |
---|
687 | (defun rassoc-if (predicate alist &key key) |
---|
688 | "Return the first cons in ALIST whose CDR satisfies PREDICATE. If KEY |
---|
689 | is supplied, apply it to the CDR of each cons before testing." |
---|
690 | (setq key (default-identity-key key)) |
---|
691 | (dolist (pair alist) |
---|
692 | (when (and pair |
---|
693 | (funcall predicate |
---|
694 | (if key (funcall key (cdr pair)) |
---|
695 | (cdr pair)))) |
---|
696 | (return pair)))) |
---|
697 | |
---|
698 | (defun rassoc-if-not (predicate alist &key key) |
---|
699 | "Return the first cons in ALIST whose CDR does not satisfy PREDICATE. |
---|
700 | If KEY is supplied, apply it to the CDR of each cons before testing." |
---|
701 | (setq key (default-identity-key key)) |
---|
702 | (dolist (pair alist) |
---|
703 | (when (and pair |
---|
704 | (not (funcall predicate |
---|
705 | (if key (funcall key (cdr pair)) |
---|
706 | (cdr pair))))) |
---|
707 | (return pair)))) |
---|
708 | |
---|
709 | |
---|
710 | (defun map1 (function original-arglists accumulate take-car) |
---|
711 | "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. |
---|
712 | It Maps function over the arglists in the appropriate way. It is done when any |
---|
713 | of the arglists runs out. Until then, it CDRs down the arglists calling the |
---|
714 | function and accumulating results as desired." |
---|
715 | (let* ((length (length original-arglists)) |
---|
716 | (arglists (make-list length)) |
---|
717 | (args (make-list length)) |
---|
718 | (ret-list (list nil)) |
---|
719 | (temp ret-list)) |
---|
720 | (declare (dynamic-extent arglists args ret-list)) |
---|
721 | (let ((argstail arglists)) |
---|
722 | (dolist (arg original-arglists) |
---|
723 | (setf (car (the cons argstail)) arg) |
---|
724 | (pop argstail))) |
---|
725 | (do ((res nil) |
---|
726 | (argstail args args)) |
---|
727 | ((memq nil arglists) |
---|
728 | (if accumulate |
---|
729 | (cdr ret-list) |
---|
730 | (car original-arglists))) |
---|
731 | (do ((l arglists (cdr l))) |
---|
732 | ((not l)) |
---|
733 | (setf (car (the cons argstail)) (if take-car (car (car l)) (car l))) |
---|
734 | (rplaca l (cdr (car l))) |
---|
735 | (pop argstail)) |
---|
736 | (setq res (apply function args)) |
---|
737 | (case accumulate |
---|
738 | (:nconc |
---|
739 | (setq temp (last (nconc temp res)))) |
---|
740 | (:list (rplacd temp (list res)) |
---|
741 | (setq temp (cdr temp))))))) |
---|
742 | |
---|
743 | (defun mapc (function list &rest more-lists) |
---|
744 | "Apply FUNCTION to successive elements of lists. Return the second argument." |
---|
745 | (declare (dynamic-extent more-lists)) |
---|
746 | (let ((arglists (cons list more-lists))) |
---|
747 | (declare (dynamic-extent arglists)) |
---|
748 | (values (map1 function arglists nil t)))) |
---|
749 | |
---|
750 | (defun mapcar (function list &rest more-lists) |
---|
751 | "Apply FUNCTION to successive elements of LIST. Return list of FUNCTION |
---|
752 | return values." |
---|
753 | (declare (dynamic-extent more-lists)) |
---|
754 | (let ((arglists (cons list more-lists))) |
---|
755 | (declare (dynamic-extent arglists)) |
---|
756 | (values (map1 function arglists :list t)))) |
---|
757 | |
---|
758 | (defun mapcan (function list &rest more-lists) |
---|
759 | "Apply FUNCTION to successive elements of LIST. Return NCONC of FUNCTION |
---|
760 | results." |
---|
761 | (declare (dynamic-extent more-lists)) |
---|
762 | (let ((arglists (cons list more-lists))) |
---|
763 | (declare (dynamic-extent arglists)) |
---|
764 | (values (map1 function arglists :nconc t)))) |
---|
765 | |
---|
766 | (defun mapl (function list &rest more-lists) |
---|
767 | "Apply FUNCTION to successive CDRs of list. Return NIL." |
---|
768 | (declare (dynamic-extent more-lists)) |
---|
769 | (let ((arglists (cons list more-lists))) |
---|
770 | (declare (dynamic-extent arglists)) |
---|
771 | (values (map1 function arglists nil nil)))) |
---|
772 | |
---|
773 | (defun maplist (function list &rest more-lists) |
---|
774 | "Apply FUNCTION to successive CDRs of list. Return list of results." |
---|
775 | (declare (dynamic-extent more-lists)) |
---|
776 | (let ((arglists (cons list more-lists))) |
---|
777 | (declare (dynamic-extent arglists)) |
---|
778 | (values (map1 function arglists :list nil)))) |
---|
779 | |
---|
780 | (defun mapcon (function list &rest more-lists) |
---|
781 | "Apply FUNCTION to successive CDRs of lists. Return NCONC of results." |
---|
782 | (declare (dynamic-extent more-lists)) |
---|
783 | (let ((arglists (cons list more-lists))) |
---|
784 | (declare (dynamic-extent arglists)) |
---|
785 | (values (map1 function arglists :nconc nil)))) |
---|
786 | |
---|
787 | ;;; Functions for compatibility sake: |
---|
788 | |
---|
789 | (defun delq (item a-list &optional (n 0 np)) |
---|
790 | "Returns list with all (up to n) elements with all elements EQ to ITEM |
---|
791 | deleted" |
---|
792 | ;(%print "a-list = " a-list) |
---|
793 | (declare (type list a-list) (type integer n)) |
---|
794 | ;(%print "a-list = " a-list) |
---|
795 | (do ((x a-list (cdr x)) |
---|
796 | (splice '())) |
---|
797 | ((or (endp x) |
---|
798 | (and np (zerop n))) |
---|
799 | a-list) |
---|
800 | ; (%print "a-list = " a-list) |
---|
801 | (cond ((eq item (car x)) |
---|
802 | (setq n (- n 1)) |
---|
803 | (if (null splice) |
---|
804 | (setq a-list (cdr x)) |
---|
805 | (rplacd splice (cdr x)))) |
---|
806 | (T (setq splice x))))) ; move splice along to include element |
---|
807 | |
---|
808 | (defun list-length-and-final-cdr (list) |
---|
809 | "First value reutrned is length of regular list. |
---|
810 | [for (a b . c), returns 2] |
---|
811 | [for circular lists, returns NIL] |
---|
812 | Second value is the final cdr. |
---|
813 | [ for (a b), returns NIL |
---|
814 | for (a b . c), returns c |
---|
815 | for circular lists, returns NIL] |
---|
816 | Third value only returned if we have a circular list. It is |
---|
817 | the MAX possible length of the list until the repeat." |
---|
818 | (do* ((n 0 (+ n 2)) |
---|
819 | (fast list (cddr fast)) |
---|
820 | (slow list (cdr slow))) |
---|
821 | () |
---|
822 | (declare (fixnum n)) |
---|
823 | (cond ((null fast) |
---|
824 | (return (values n nil))) |
---|
825 | ((not (consp fast)) |
---|
826 | (return (values n fast))) |
---|
827 | ((null (cdr fast)) |
---|
828 | (return (values (1+ n) nil))) |
---|
829 | ((and (eq fast slow) (> n 0)) ;circular list |
---|
830 | (return (values nil nil n))) |
---|
831 | ((not (consp (cdr fast))) |
---|
832 | (return (values (1+ n) (cdr fast))))))) |
---|
833 | |
---|
834 | (provide 'lists) |
---|