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