source: branches/qres/ccl/lib/lists.lisp @ 14259

Last change on this file since 14259 was 14049, checked in by gz, 9 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.1 KB
Line 
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
585on 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)
Note: See TracBrowser for help on using the repository browser.