1;;; sets.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id$
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;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34;;; From CMUCL.
35
36(defmacro with-set-keys (funcall)
37  `(cond (notp ,(append funcall '(:key key :test-not test-not)))
38	 (t ,(append funcall '(:key key :test test)))))
39
40(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
41  (require-type list2 'list)
42  (when (and testp notp)
43    (error "Both :TEST and :TEST-NOT were supplied."))
44  (when key
45    (setq key (coerce-to-function key)))
46  (let ((res list2))
47    (dolist (elt list1)
48      (unless (with-set-keys (member (funcall-key key elt) list2))
49	(push elt res)))
50    res))
51
52(defmacro steve-splice (source destination)
53  `(let ((temp ,source))
54     (setf ,source (cdr ,source)
55	   (cdr temp) ,destination
56	   ,destination temp)))
57
58(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
59  (when (and testp notp)
60    (error "Both :TEST and :TEST-NOT were supplied."))
61  (when key
62    (setq key (coerce-to-function key)))
63  (let ((res list2)
64	(list1 list1))
65    (do ()
66        ((endp list1))
67      (if (not (with-set-keys (member (funcall-key key (car list1)) list2)))
68	  (steve-splice list1 res)
69	  (setf list1 (cdr list1))))
70    res))
71
72
73(defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp))
74  (when (and testp notp)
75    (error "Both :TEST and :TEST-NOT were supplied."))
76  (when key
77    (setq key (coerce-to-function key)))
78  (let ((res nil))
79    (dolist (elt list1)
80      (if (with-set-keys (member (funcall-key key elt) list2))
81	  (push elt res)))
82    res))
83
84(defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp))
85  (when (and testp notp)
86    (error "Both :TEST and :TEST-NOT were supplied."))
87  (when key
88    (setq key (coerce-to-function key)))
89  (let ((res nil)
90	(list1 list1))
91    (do () ((endp list1))
92      (if (with-set-keys (member (funcall-key key (car list1)) list2))
93	  (steve-splice list1 res)
94	  (setq list1 (cdr list1))))
95    res))
96
97(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
98  (when (and testp notp)
99    (error "Both :TEST and :TEST-NOT were supplied."))
100  (when key
101    (setq key (coerce-to-function key)))
102  (if (null list2)
103      list1
104      (let ((res nil))
105	(dolist (elt list1)
106	  (if (not (with-set-keys (member (funcall-key key elt) list2)))
107	      (push elt res)))
108	res)))
109
110
111(defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
112  (when (and testp notp)
113    (error "Both :TEST and :TEST-NOT were supplied."))
114  (when key
115    (setq key (coerce-to-function key)))
116  (let ((res nil)
117	(list1 list1))
118    (do () ((endp list1))
119      (if (not (with-set-keys (member (funcall-key key (car list1)) list2)))
120	  (steve-splice list1 res)
121	  (setq list1 (cdr list1))))
122    res))
123
124
125(defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp))
126  (when (and testp notp)
127    (error "Both :TEST and :TEST-NOT were supplied."))
128  (when key
129    (setq key (coerce-to-function key)))
130  (let ((result nil)
131        (key (when key (coerce key 'function)))
132        (test (coerce test 'function))
133        (test-not (if test-not (coerce test-not 'function) #'eql)))
134    (dolist (elt list1)
135      (unless (with-set-keys (member (funcall-key key elt) list2))
136	(setq result (cons elt result))))
137    (let ((test (if testp
138                    (lambda (x y) (funcall test y x))
139                    test))
140          (test-not (if notp
141                        (lambda (x y) (funcall test-not y x))
142                        test-not)))
143      (dolist (elt list2)
144        (unless (with-set-keys (member (funcall-key key elt) list1))
145          (setq result (cons elt result)))))
146    result))
147
148;;; Adapted from SBCL.
149(defun nset-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not #'eql notp))
150  (when (and testp notp)
151    (error "Both :TEST and :TEST-NOT were supplied."))
152  (let ((key (and key (coerce-to-function key)))
153        (test (if testp (coerce-to-function test) test))
154        (test-not (if notp (coerce-to-function test-not) test-not)))
155    ;; The outer loop examines LIST1 while the inner loop examines
156    ;; LIST2. If an element is found in LIST2 "equal" to the element
157    ;; in LIST1, both are spliced out. When the end of LIST1 is
158    ;; reached, what is left of LIST2 is tacked onto what is left of
159    ;; LIST1. The splicing operation ensures that the correct
160    ;; operation is performed depending on whether splice is at the
161    ;; top of the list or not.
162    (do ((list1 list1)
163         (list2 list2)
164         (x list1 (cdr x))
165         (splicex ())
166         (deleted-y ())
167         ;; elements of LIST2, which are "equal" to some processed
168         ;; earlier elements of LIST1
169         )
170        ((endp x)
171         (if (null splicex)
172             (setq list1 list2)
173             (rplacd splicex list2))
174         list1)
175      (let ((key-val-x (apply-key key (car x)))
176            (found-duplicate nil))
177
178        ;; Move all elements from LIST2, which are "equal" to (CAR X),
179        ;; to DELETED-Y.
180        (do* ((y list2 next-y)
181              (next-y (cdr y) (cdr y))
182              (splicey ()))
183             ((endp y))
184          (cond ((let ((key-val-y (apply-key key (car y))))
185                   (if notp
186                       (not (funcall test-not key-val-x key-val-y))
187                       (funcall test key-val-x key-val-y)))
188                 (if (null splicey)
189                     (setq list2 (cdr y))
190                     (rplacd splicey (cdr y)))
191                 (setq deleted-y (rplacd y deleted-y))
192                 (setq found-duplicate t))
193                (t (setq splicey y))))
194
195        (unless found-duplicate
196          (setq found-duplicate (with-set-keys (member key-val-x deleted-y))))
197
198        (if found-duplicate
199            (if (null splicex)
200                (setq list1 (cdr x))
201                (rplacd splicex (cdr x)))
202            (setq splicex x))))))
203
204;;; Adapted from SBCL.
205(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
206  (require-type list2 'list)
207  (when (and testp notp)
208    (error "Both :TEST and :TEST-NOT were supplied."))
209  (let ((key (and key (coerce-to-function key))))
210    (dolist (elt list1)
211      (unless (with-set-keys (member (funcall-key key elt) list2))
212        (return-from subsetp nil)))
213    t))
214