Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
-
19a305de
by Raymond Toy at 2023-08-16T14:28:11+00:00
-
9d593e3a
by Raymond Toy at 2023-08-16T14:28:55+00:00
2 changed files:
Changes:
| ... | ... | @@ -45,7 +45,7 @@ |
| 45 | 45 | tree-equal list-length nth %setnth nthcdr last make-list append
|
| 46 | 46 | copy-list copy-alist copy-tree revappend nconc nreconc butlast
|
| 47 | 47 | nbutlast ldiff member member-if member-if-not tailp adjoin union
|
| 48 | - nunion intersection nintersection set-difference nset-difference
|
|
| 48 | + nunion intersection nintersection nset-difference
|
|
| 49 | 49 | set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc
|
| 50 | 50 | assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
|
| 51 | 51 | subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
|
| ... | ... | @@ -744,6 +744,39 @@ |
| 744 | 744 | list
|
| 745 | 745 | (cons item list)))
|
| 746 | 746 | |
| 747 | +;; The minimum length of a list before we can use a hashtable. This
|
|
| 748 | +;; was determined experimentally.
|
|
| 749 | +(defparameter *min-list-length-for-hashtable*
|
|
| 750 | + 15)
|
|
| 751 | + |
|
| 752 | +;; Convert a list to a hashtable. The hashtable does not handle
|
|
| 753 | +;; duplicated values in the list. Returns the hashtable.
|
|
| 754 | +(defun list-to-hashtable (list key test test-not)
|
|
| 755 | + ;; Don't currently support test-not when converting a list to a hashtable
|
|
| 756 | + (unless test-not
|
|
| 757 | + (let ((hash-test (let ((test-fn (if (and (symbolp test)
|
|
| 758 | + (fboundp test))
|
|
| 759 | + (fdefinition test)
|
|
| 760 | + test)))
|
|
| 761 | + (cond ((eql test-fn #'eq) 'eq)
|
|
| 762 | + ((eql test-fn #'eql) 'eql)
|
|
| 763 | + ((eql test-fn #'equal) 'equal)
|
|
| 764 | + ((eql test-fn #'equalp) 'equalp)))))
|
|
| 765 | + (unless hash-test
|
|
| 766 | + (return-from list-to-hashtable nil))
|
|
| 767 | + ;; If the list is too short, the hashtable makes things
|
|
| 768 | + ;; slower. We also need to balance memory usage.
|
|
| 769 | + (let ((len 0))
|
|
| 770 | + ;; Compute list length ourselves.
|
|
| 771 | + (dolist (item list)
|
|
| 772 | + (declare (ignore item))
|
|
| 773 | + (incf len))
|
|
| 774 | + (when (< len *min-list-length-for-hashtable*)
|
|
| 775 | + (return-from list-to-hashtable nil))
|
|
| 776 | + (let ((hashtable (make-hash-table :test hash-test :size len)))
|
|
| 777 | + (dolist (item list)
|
|
| 778 | + (setf (gethash (apply-key key item) hashtable) item))
|
|
| 779 | + hashtable)))))
|
|
| 747 | 780 | |
| 748 | 781 | ;;; UNION -- Public.
|
| 749 | 782 | ;;;
|
| ... | ... | @@ -812,20 +845,32 @@ |
| 812 | 845 | (setq list1 (Cdr list1))))
|
| 813 | 846 | res))
|
| 814 | 847 | |
| 815 | -(defun set-difference (list1 list2 &key key
|
|
| 816 | - (test #'eql testp) (test-not nil notp))
|
|
| 848 | +(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
|
|
| 817 | 849 | "Returns the elements of list1 which are not in list2."
|
| 818 | 850 | (declare (inline member))
|
| 819 | 851 | (if (and testp notp)
|
| 820 | 852 | (error "Test and test-not both supplied."))
|
| 821 | - (if (null list2)
|
|
| 822 | - list1
|
|
| 823 | - (let ((res nil))
|
|
| 824 | - (dolist (elt list1)
|
|
| 825 | - (if (not (with-set-keys (member (apply-key key elt) list2)))
|
|
| 826 | - (push elt res)))
|
|
| 827 | - res)))
|
|
| 828 | - |
|
| 853 | + ;; Quick exit
|
|
| 854 | + (when (null list2)
|
|
| 855 | + (return-from set-difference list1))
|
|
| 856 | + |
|
| 857 | + (let ((hashtable
|
|
| 858 | + (list-to-hashtable list2 key test test-not)))
|
|
| 859 | + (cond (hashtable
|
|
| 860 | + ;; list2 was placed in hash table.
|
|
| 861 | + (let ((res nil))
|
|
| 862 | + (dolist (item list1)
|
|
| 863 | + (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
| 864 | + (push item res)))
|
|
| 865 | + res))
|
|
| 866 | + ((null hashtable)
|
|
| 867 | + ;; Default implementation because we didn't create the hash
|
|
| 868 | + ;; table.
|
|
| 869 | + (let ((res nil))
|
|
| 870 | + (dolist (item list1)
|
|
| 871 | + (if (not (with-set-keys (member (apply-key key item) list2)))
|
|
| 872 | + (push item res)))
|
|
| 873 | + res)))))
|
|
| 829 | 874 | |
| 830 | 875 | (defun nset-difference (list1 list2 &key key
|
| 831 | 876 | (test #'eql testp) (test-not nil notp))
|
| 1 | +;; Tests for sets
|
|
| 2 | + |
|
| 3 | +(defpackage :sets-tests
|
|
| 4 | + (:use :cl :lisp-unit))
|
|
| 5 | + |
|
| 6 | +(in-package "SETS-TESTS")
|
|
| 7 | + |
|
| 8 | +(define-test set-diff.hash-eql
|
|
| 9 | + (:tag :issues)
|
|
| 10 | + ;; For set-difference to use hashtables by making the threshold
|
|
| 11 | + ;; small.
|
|
| 12 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 13 | + (assert-equal '(2 2 1)
|
|
| 14 | + (set-difference '(1 2 2 3) '(3 4)))
|
|
| 15 | + (assert-equal '(2 2 1)
|
|
| 16 | + (set-difference '(1 2 2 3) '(3 4 5 6 7 8)))
|
|
| 17 | + (assert-equal '(2 2 1)
|
|
| 18 | + (set-difference '(1 2 2 3) '(3 4)
|
|
| 19 | + :test #'eql))
|
|
| 20 | + (assert-equal '(2 2 1)
|
|
| 21 | + (set-difference '(1 2 2 3) '(3 4 5 6 7 8)
|
|
| 22 | + :test #'eql))))
|
|
| 23 | + |
|
| 24 | +(define-test set-diff.hash-eq
|
|
| 25 | + (:tag :issues)
|
|
| 26 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 27 | + (assert-equal '(b b a)
|
|
| 28 | + (set-difference '(a b b c) '(c d e) :test 'eq))
|
|
| 29 | + (assert-equal '(b b a)
|
|
| 30 | + (set-difference '(a b b c) '(c d e f g h) :test 'eq))
|
|
| 31 | + (assert-equal '(b b a)
|
|
| 32 | + (set-difference '(a b b c) '(c d e) :test #'eq))
|
|
| 33 | + (assert-equal '(b b a)
|
|
| 34 | + (set-difference '(a b b c) '(c d e f g h) :test #'eq))))
|
|
| 35 | + |
|
| 36 | +(define-test set-diff.hash-equal
|
|
| 37 | + (:tag :issues)
|
|
| 38 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 39 | + (assert-equal '("b" "b" "a")
|
|
| 40 | + (set-difference '("a" "b" "b" "c")
|
|
| 41 | + '("c" "d" "e")
|
|
| 42 | + :test 'equal))
|
|
| 43 | + (assert-equal '("b" "b" "a")
|
|
| 44 | + (set-difference '("a" "b" "b" "c")
|
|
| 45 | + '("c" "d" "e" "f" "g" "h")
|
|
| 46 | + :test 'equal))
|
|
| 47 | + (assert-equal '("b" "b" "a")
|
|
| 48 | + (set-difference '("a" "b" "b" "c")
|
|
| 49 | + '("c" "d" "e")
|
|
| 50 | + :test #'equal))
|
|
| 51 | + (assert-equal '("b" "b" "a")
|
|
| 52 | + (set-difference '("a" "b" "b" "c")
|
|
| 53 | + '("c" "d" "e" "f" "g" "h")
|
|
| 54 | + :test #'equal))))
|
|
| 55 | + |
|
| 56 | +(define-test set-diff.hash-equalp
|
|
| 57 | + (:tag :issues)
|
|
| 58 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 59 | + (assert-equal '("b" "b" "a")
|
|
| 60 | + (set-difference '("a" "b" "b" "c")
|
|
| 61 | + '("C" "d" "e")
|
|
| 62 | + :test 'equalp))
|
|
| 63 | + (assert-equal '("b" "b" "a")
|
|
| 64 | + (set-difference '("a" "b" "b" "C")
|
|
| 65 | + '("c" "D" "e" "f" "g" "h")
|
|
| 66 | + :test 'equalp))
|
|
| 67 | + (assert-equal '("b" "b" "a")
|
|
| 68 | + (set-difference '("a" "b" "b" "c")
|
|
| 69 | + '("C" "d" "e")
|
|
| 70 | + :test #'equalp))
|
|
| 71 | + (assert-equal '("b" "b" "a")
|
|
| 72 | + (set-difference '("a" "b" "b" "C")
|
|
| 73 | + '("c" "D" "e" "f" "g" "h")
|
|
| 74 | + :test #'equalp))))
|
|
| 75 | + |
|
| 76 | +;; Simple test that we handle a key correctly
|
|
| 77 | +(define-test set-diff.hash-eql-with-key
|
|
| 78 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 79 | + (assert-equal '((3 "b") (2 "b"))
|
|
| 80 | + (set-difference '((1 "a") (2 "b") (3 "b"))
|
|
| 81 | + '((1 "a") (4 "c") (5 "d"))
|
|
| 82 | + :key #'first))))
|
|
| 83 | + |
|
| 84 | +(define-test set-diff.test-and-test-not
|
|
| 85 | + (assert-error 'simple-error
|
|
| 86 | + (set-difference '(1 2)
|
|
| 87 | + '(3 4)
|
|
| 88 | + :test 'eql
|
|
| 89 | + :test-not 'eql)))
|
|
| 90 | + |
|
| 91 | + |