Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl
Commits:
-
55c01f44
by Raymond Toy at 2023-08-17T13:33:59+00:00
-
14d847f0
by Raymond Toy at 2023-08-17T13:34:15+00:00
-
c9ce7574
by Raymond Toy at 2023-08-17T13:36:18+00:00
-
5c7536f0
by Raymond Toy at 2023-08-17T13:36:44+00:00
-
181508a9
by Raymond Toy at 2023-08-17T06:47:03-07:00
-
611a0377
by Raymond Toy at 2023-08-17T15:27:54-07:00
2 changed files:
Changes:
| ... | ... | @@ -788,11 +788,18 @@ |
| 788 | 788 | (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
|
| 789 | 789 | "Returns the union of list1 and list2."
|
| 790 | 790 | (declare (inline member))
|
| 791 | - (when (and testp notp) (error (intl:gettext "Test and test-not both supplied.")))
|
|
| 792 | - (let ((res list2))
|
|
| 793 | - (dolist (elt list1)
|
|
| 794 | - (unless (with-set-keys (member (apply-key key elt) list2))
|
|
| 795 | - (push elt res)))
|
|
| 791 | + (when (and testp notp)
|
|
| 792 | + (error (intl:gettext "Test and test-not both supplied.")))
|
|
| 793 | + (let ((res list2)
|
|
| 794 | + (hashtable (list-to-hashtable list2 key test test-not)))
|
|
| 795 | + (cond (hashtable
|
|
| 796 | + (dolist (item list1)
|
|
| 797 | + (unless (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
| 798 | + (push item res))))
|
|
| 799 | + ((null hashtable)
|
|
| 800 | + (dolist (item list1)
|
|
| 801 | + (unless (with-set-keys (member (apply-key key item) list2))
|
|
| 802 | + (push item res)))))
|
|
| 796 | 803 | res))
|
| 797 | 804 | |
| 798 | 805 | ;;; Destination and source are setf-able and many-evaluable. Sets the source
|
| ... | ... | @@ -825,11 +832,20 @@ |
| 825 | 832 | (declare (inline member))
|
| 826 | 833 | (if (and testp notp)
|
| 827 | 834 | (error "Test and test-not both supplied."))
|
| 828 | - (let ((res nil))
|
|
| 829 | - (dolist (elt list1)
|
|
| 830 | - (if (with-set-keys (member (apply-key key elt) list2))
|
|
| 831 | - (push elt res)))
|
|
| 832 | - res))
|
|
| 835 | + (let ((hashtable
|
|
| 836 | + (list-to-hashtable list2 key test test-not)))
|
|
| 837 | + (cond (hashtable
|
|
| 838 | + (let ((res nil))
|
|
| 839 | + (dolist (item list1)
|
|
| 840 | + (when (nth-value 1 (gethash (apply-key key item) hashtable))
|
|
| 841 | + (push item res)))
|
|
| 842 | + res))
|
|
| 843 | + ((null hashtable)
|
|
| 844 | + (let ((res nil))
|
|
| 845 | + (dolist (elt list1)
|
|
| 846 | + (if (with-set-keys (member (apply-key key elt) list2))
|
|
| 847 | + (push elt res)))
|
|
| 848 | + res)))))
|
|
| 833 | 849 | |
| 834 | 850 | (defun nintersection (list1 list2 &key key
|
| 835 | 851 | (test #'eql testp) (test-not nil notp))
|
| ... | ... | @@ -89,3 +89,86 @@ |
| 89 | 89 | :test-not 'eql)))
|
| 90 | 90 | |
| 91 | 91 |
|
| 92 | + |
|
| 93 | +(define-test union.hash-eql
|
|
| 94 | + (:tag :issues)
|
|
| 95 | + ;; For union to use hashtables by making the threshold
|
|
| 96 | + ;; small.
|
|
| 97 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 98 | + (assert-equal '(2 2 1 3 4)
|
|
| 99 | + (union '(1 2 2 3) '(3 4)))
|
|
| 100 | + (assert-equal '(2 2 1 3 4 5 6 7 8)
|
|
| 101 | + (union '(1 2 2 3) '(3 4 5 6 7 8)))
|
|
| 102 | + (assert-equal '(2 2 1 3 4)
|
|
| 103 | + (union '(1 2 2 3) '(3 4)
|
|
| 104 | + :test #'eql))
|
|
| 105 | + (assert-equal '(2 2 1 3 4 5 6 7 8)
|
|
| 106 | + (union '(1 2 2 3) '(3 4 5 6 7 8)
|
|
| 107 | + :test #'eql))))
|
|
| 108 | + |
|
| 109 | +(define-test union.hash-eq
|
|
| 110 | + (:tag :issues)
|
|
| 111 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 112 | + (assert-equal '(b b a c d e)
|
|
| 113 | + (union '(a b b c) '(c d e) :test 'eq))
|
|
| 114 | + (assert-equal '(b b a c d e f g h)
|
|
| 115 | + (union '(a b b c) '(c d e f g h) :test 'eq))
|
|
| 116 | + (assert-equal '(b b a c d e)
|
|
| 117 | + (union '(a b b c) '(c d e) :test #'eq))
|
|
| 118 | + (assert-equal '(b b a c d e f g h)
|
|
| 119 | + (union '(a b b c) '(c d e f g h) :test #'eq))))
|
|
| 120 | + |
|
| 121 | +(define-test union.hash-equal
|
|
| 122 | + (:tag :issues)
|
|
| 123 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 124 | + (assert-equal '("b" "b" "a" "c" "d" "e")
|
|
| 125 | + (union '("a" "b" "b" "c")
|
|
| 126 | + '("c" "d" "e")
|
|
| 127 | + :test 'equal))
|
|
| 128 | + (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h")
|
|
| 129 | + (union '("a" "b" "b" "c")
|
|
| 130 | + '("c" "d" "e" "f" "g" "h")
|
|
| 131 | + :test 'equal))
|
|
| 132 | + (assert-equal '("b" "b" "a" "c" "d" "e")
|
|
| 133 | + (union '("a" "b" "b" "c")
|
|
| 134 | + '("c" "d" "e")
|
|
| 135 | + :test #'equal))
|
|
| 136 | + (assert-equal '("b" "b" "a" "c" "d" "e" "f" "g" "h")
|
|
| 137 | + (union '("a" "b" "b" "c")
|
|
| 138 | + '("c" "d" "e" "f" "g" "h")
|
|
| 139 | + :test #'equal))))
|
|
| 140 | + |
|
| 141 | +(define-test union.hash-equalp
|
|
| 142 | + (:tag :issues)
|
|
| 143 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 144 | + (assert-equal '("b" "b" "a" "C" "d" "e")
|
|
| 145 | + (union '("a" "b" "b" "c")
|
|
| 146 | + '("C" "d" "e")
|
|
| 147 | + :test 'equalp))
|
|
| 148 | + (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h")
|
|
| 149 | + (union '("a" "b" "b" "C")
|
|
| 150 | + '("c" "D" "e" "f" "g" "h")
|
|
| 151 | + :test 'equalp))
|
|
| 152 | + (assert-equal '("b" "b" "a" "C" "d" "e")
|
|
| 153 | + (union '("a" "b" "b" "c")
|
|
| 154 | + '("C" "d" "e")
|
|
| 155 | + :test #'equalp))
|
|
| 156 | + (assert-equal '("b" "b" "a" "c" "D" "e" "f" "g" "h")
|
|
| 157 | + (union '("a" "b" "b" "C")
|
|
| 158 | + '("c" "D" "e" "f" "g" "h")
|
|
| 159 | + :test #'equalp))))
|
|
| 160 | + |
|
| 161 | +;; Simple test that we handle a key correctly
|
|
| 162 | +(define-test union.hash-eql-with-key
|
|
| 163 | + (let ((lisp::*min-list-length-for-hashtable* 2))
|
|
| 164 | + (assert-equal '((3 "b") (2 "b") (1 "a") (4 "c") (5 "d"))
|
|
| 165 | + (union '((1 "a") (2 "b") (3 "b"))
|
|
| 166 | + '((1 "a") (4 "c") (5 "d"))
|
|
| 167 | + :key #'first))))
|
|
| 168 | + |
|
| 169 | +(define-test union.test-and-test-not
|
|
| 170 | + (assert-error 'simple-error
|
|
| 171 | + (union '(1 2)
|
|
| 172 | + '(3 4)
|
|
| 173 | + :test 'eql
|
|
| 174 | + :test-not 'eql))) |