source: trunk/j/src/org/armedbear/lisp/sets.lisp @ 11297

Last change on this file since 11297 was 11297, checked in by ehuelsmann, 13 years ago

Set Id keyword for expansion.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.9 KB
Line 
1;;; sets.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: sets.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package #:system)
21
22;;; From CMUCL.
23
24(defmacro with-set-keys (funcall)
25  `(cond (notp ,(append funcall '(:key key :test-not test-not)))
26   (t ,(append funcall '(:key key :test test)))))
27
28(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
29  (require-type list2 'list)
30  (when (and testp notp)
31    (error "Both :TEST and :TEST-NOT were supplied."))
32  (when key
33    (setq key (coerce-to-function key)))
34  (let ((res list2))
35    (dolist (elt list1)
36      (unless (with-set-keys (member (funcall-key key elt) list2))
37  (push elt res)))
38    res))
39
40(defmacro steve-splice (source destination)
41  `(let ((temp ,source))
42     (setf ,source (cdr ,source)
43     (cdr temp) ,destination
44     ,destination temp)))
45
46(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
47  (when (and testp notp)
48    (error "Both :TEST and :TEST-NOT were supplied."))
49  (when key
50    (setq key (coerce-to-function key)))
51  (let ((res list2)
52  (list1 list1))
53    (do ()
54        ((endp list1))
55      (if (not (with-set-keys (member (funcall-key key (car list1)) list2)))
56    (steve-splice list1 res)
57    (setf list1 (cdr list1))))
58    res))
59
60
61(defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp))
62  (when (and testp notp)
63    (error "Both :TEST and :TEST-NOT were supplied."))
64  (when key
65    (setq key (coerce-to-function key)))
66  (let ((res nil))
67    (dolist (elt list1)
68      (if (with-set-keys (member (funcall-key key elt) list2))
69    (push elt res)))
70    res))
71
72(defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp))
73  (when (and testp notp)
74    (error "Both :TEST and :TEST-NOT were supplied."))
75  (when key
76    (setq key (coerce-to-function key)))
77  (let ((res nil)
78  (list1 list1))
79    (do () ((endp list1))
80      (if (with-set-keys (member (funcall-key key (car list1)) list2))
81    (steve-splice list1 res)
82    (setq list1 (cdr list1))))
83    res))
84
85(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
86  (when (and testp notp)
87    (error "Both :TEST and :TEST-NOT were supplied."))
88  (when key
89    (setq key (coerce-to-function key)))
90  (if (null list2)
91      list1
92      (let ((res nil))
93  (dolist (elt list1)
94    (if (not (with-set-keys (member (funcall-key key elt) list2)))
95        (push elt res)))
96  res)))
97
98
99(defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
100  (when (and testp notp)
101    (error "Both :TEST and :TEST-NOT were supplied."))
102  (when key
103    (setq key (coerce-to-function key)))
104  (let ((res nil)
105  (list1 list1))
106    (do () ((endp list1))
107      (if (not (with-set-keys (member (funcall-key key (car list1)) list2)))
108    (steve-splice list1 res)
109    (setq list1 (cdr list1))))
110    res))
111
112
113(defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp))
114  (when (and testp notp)
115    (error "Both :TEST and :TEST-NOT were supplied."))
116  (when key
117    (setq key (coerce-to-function key)))
118  (let ((result nil)
119        (key (when key (coerce key 'function)))
120        (test (coerce test 'function))
121        (test-not (if test-not (coerce test-not 'function) #'eql)))
122    (dolist (elt list1)
123      (unless (with-set-keys (member (funcall-key key elt) list2))
124  (setq result (cons elt result))))
125    (let ((test (if testp
126                    (lambda (x y) (funcall test y x))
127                    test))
128          (test-not (if notp
129                        (lambda (x y) (funcall test-not y x))
130                        test-not)))
131      (dolist (elt list2)
132        (unless (with-set-keys (member (funcall-key key elt) list1))
133          (setq result (cons elt result)))))
134    result))
135
136;;; Adapted from SBCL.
137(defun nset-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not #'eql notp))
138  (when (and testp notp)
139    (error "Both :TEST and :TEST-NOT were supplied."))
140  (let ((key (and key (coerce-to-function key)))
141        (test (if testp (coerce-to-function test) test))
142        (test-not (if notp (coerce-to-function test-not) test-not)))
143    ;; The outer loop examines LIST1 while the inner loop examines
144    ;; LIST2. If an element is found in LIST2 "equal" to the element
145    ;; in LIST1, both are spliced out. When the end of LIST1 is
146    ;; reached, what is left of LIST2 is tacked onto what is left of
147    ;; LIST1. The splicing operation ensures that the correct
148    ;; operation is performed depending on whether splice is at the
149    ;; top of the list or not.
150    (do ((list1 list1)
151         (list2 list2)
152         (x list1 (cdr x))
153         (splicex ())
154         (deleted-y ())
155         ;; elements of LIST2, which are "equal" to some processed
156         ;; earlier elements of LIST1
157         )
158        ((endp x)
159         (if (null splicex)
160             (setq list1 list2)
161             (rplacd splicex list2))
162         list1)
163      (let ((key-val-x (apply-key key (car x)))
164            (found-duplicate nil))
165
166        ;; Move all elements from LIST2, which are "equal" to (CAR X),
167        ;; to DELETED-Y.
168        (do* ((y list2 next-y)
169              (next-y (cdr y) (cdr y))
170              (splicey ()))
171             ((endp y))
172          (cond ((let ((key-val-y (apply-key key (car y))))
173                   (if notp
174                       (not (funcall test-not key-val-x key-val-y))
175                       (funcall test key-val-x key-val-y)))
176                 (if (null splicey)
177                     (setq list2 (cdr y))
178                     (rplacd splicey (cdr y)))
179                 (setq deleted-y (rplacd y deleted-y))
180                 (setq found-duplicate t))
181                (t (setq splicey y))))
182
183        (unless found-duplicate
184          (setq found-duplicate (with-set-keys (member key-val-x deleted-y))))
185
186        (if found-duplicate
187            (if (null splicex)
188                (setq list1 (cdr x))
189                (rplacd splicex (cdr x)))
190            (setq splicex x))))))
191
192;;; Adapted from SBCL.
193(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
194  (require-type list2 'list)
195  (when (and testp notp)
196    (error "Both :TEST and :TEST-NOT were supplied."))
197  (let ((key (and key (coerce-to-function key))))
198    (dolist (elt list1)
199      (unless (with-set-keys (member (funcall-key key elt) list2))
200        (return-from subsetp nil)))
201    t))
Note: See TracBrowser for help on using the repository browser.