| ... |
... |
@@ -752,6 +752,28 @@ |
|
752
|
752
|
(declaim (start-block list-to-hashtable
|
|
753
|
753
|
union intersection set-difference
|
|
754
|
754
|
nunion nintersection nset-difference))
|
|
|
755
|
+
|
|
|
756
|
+;; Main code to process a set function. INIT-RES initializes the
|
|
|
757
|
+;; value of RES, which holds the result of the set function.
|
|
|
758
|
+;; TEST-FORM is a form that tests whether to add the item from LIST1
|
|
|
759
|
+;; to RES.
|
|
|
760
|
+(defmacro process-set-body (init-res invert-p test-form)
|
|
|
761
|
+ `(let ((res ,init-res))
|
|
|
762
|
+ (dolist (item list1)
|
|
|
763
|
+ (when ,(if invert-p
|
|
|
764
|
+ `(not ,test-form)
|
|
|
765
|
+ test-form)
|
|
|
766
|
+ (push item res)))
|
|
|
767
|
+ res))
|
|
|
768
|
+
|
|
|
769
|
+(defmacro process-set (init-res invert-p)
|
|
|
770
|
+ `(let ((hashtable (list-to-hashtable list2 key test test-not)))
|
|
|
771
|
+ (if hashtable
|
|
|
772
|
+ (process-set-body ,init-res ,invert-p
|
|
|
773
|
+ (nth-value 1 (gethash (apply-key key item) hashtable)))
|
|
|
774
|
+ (process-set-body ,init-res ,invert-p
|
|
|
775
|
+ (with-set-keys (member (apply-key key item) list2))))))
|
|
|
776
|
+
|
|
755
|
777
|
;; Convert a list to a hashtable. The hashtable does not handle
|
|
756
|
778
|
;; duplicated values in the list. Returns the hashtable.
|
|
757
|
779
|
(defun list-to-hashtable (list key test test-not)
|
| ... |
... |
@@ -793,17 +815,7 @@ |
|
793
|
815
|
(declare (inline member))
|
|
794
|
816
|
(when (and testp notp)
|
|
795
|
817
|
(error (intl:gettext "Test and test-not both supplied.")))
|
|
796
|
|
- (let ((res list2)
|
|
797
|
|
- (hashtable (list-to-hashtable list2 key test test-not)))
|
|
798
|
|
- (cond (hashtable
|
|
799
|
|
- (dolist (item list1)
|
|
800
|
|
- (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
801
|
|
- (push item res))))
|
|
802
|
|
- ((null hashtable)
|
|
803
|
|
- (dolist (item list1)
|
|
804
|
|
- (unless (with-set-keys (member (apply-key key item) list2))
|
|
805
|
|
- (push item res)))))
|
|
806
|
|
- res))
|
|
|
818
|
+ (process-set list2 t))
|
|
807
|
819
|
|
|
808
|
820
|
|
|
809
|
821
|
(defun intersection (list1 list2 &key key
|
| ... |
... |
@@ -812,20 +824,7 @@ |
|
812
|
824
|
(declare (inline member))
|
|
813
|
825
|
(if (and testp notp)
|
|
814
|
826
|
(error "Test and test-not both supplied."))
|
|
815
|
|
- (let ((hashtable
|
|
816
|
|
- (list-to-hashtable list2 key test test-not)))
|
|
817
|
|
- (cond (hashtable
|
|
818
|
|
- (let ((res nil))
|
|
819
|
|
- (dolist (item list1)
|
|
820
|
|
- (when (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
821
|
|
- (push item res)))
|
|
822
|
|
- res))
|
|
823
|
|
- ((null hashtable)
|
|
824
|
|
- (let ((res nil))
|
|
825
|
|
- (dolist (elt list1)
|
|
826
|
|
- (if (with-set-keys (member (apply-key key elt) list2))
|
|
827
|
|
- (push elt res)))
|
|
828
|
|
- res)))))
|
|
|
827
|
+ (process-set nil nil))
|
|
829
|
828
|
|
|
830
|
829
|
(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
|
|
831
|
830
|
"Returns the elements of list1 which are not in list2."
|
| ... |
... |
@@ -836,23 +835,8 @@ |
|
836
|
835
|
(when (null list2)
|
|
837
|
836
|
(return-from set-difference list1))
|
|
838
|
837
|
|
|
839
|
|
- (let ((hashtable
|
|
840
|
|
- (list-to-hashtable list2 key test test-not)))
|
|
841
|
|
- (cond (hashtable
|
|
842
|
|
- ;; list2 was placed in hash table.
|
|
843
|
|
- (let ((res nil))
|
|
844
|
|
- (dolist (item list1)
|
|
845
|
|
- (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
846
|
|
- (push item res)))
|
|
847
|
|
- res))
|
|
848
|
|
- ((null hashtable)
|
|
849
|
|
- ;; Default implementation because we didn't create the hash
|
|
850
|
|
- ;; table.
|
|
851
|
|
- (let ((res nil))
|
|
852
|
|
- (dolist (item list1)
|
|
853
|
|
- (if (not (with-set-keys (member (apply-key key item) list2)))
|
|
854
|
|
- (push item res)))
|
|
855
|
|
- res)))))
|
|
|
838
|
+ (process-set nil t))
|
|
|
839
|
+
|
|
856
|
840
|
|
|
857
|
841
|
;;; Destination and source are setf-able and many-evaluable. Sets the source
|
|
858
|
842
|
;;; to the cdr, and "conses" the 1st elt of source to destination.
|