GitLab

at 2023-08-25T14:15:52+00:00

Address #240: Use hashtable for nset-diff, nunion, nintersection

Merge branch 'issue-240-add-hashtable-for-destructive-set-ops' into 'master'

Address #240: Use hashtable for nset-diff, nunion, nintersection

See merge request cmucl/cmucl!167
Merge branch 'master' into issue-240-add-hashtable-set-exclusive-or

 (defparameter *min-list-length-for-hashtable*

   15)

-(declaim (start-block list-to-hashtable union intersection set-difference))

+(declaim (start-block list-to-hashtable

+                      union intersection set-difference

+                      nunion nintersection nset-difference))

 ;; Main code to process a set function.  INIT-RES initializes the

 ;; value of RES, which holds the result of the set function.

   (process-set nil t))

-(declaim (end-block))

-

 ;;; Destination and source are setf-able and many-evaluable.  Sets the source

 ;;; to the cdr, and "conses" the 1st elt of source to destination.

 ;;;

 	   (cdr temp) ,destination

 	   ,destination temp)))

+;;; Main body for destructive set operations.  INIT-RES initializes

+;;; the result list.  INVERT-P is T if the result of the TEST-FORM

+;;; should be inverted.  TEST-FORM is the form used for determining

+;;; how to update the result.

+(defmacro nprocess-set-body (init-res invert-p test-form)

+  `(let ((res ,init-res)

+         (list1 list1))

+     (do ()

+         ((endp list1))

+       (if ,(if invert-p

+                `(not ,test-form)

+                test-form)

+           (steve-splice list1 res)

+           (setq list1 (cdr list1))))

+     res))

+

+;; Implementation of the destructive set operations.  INIT-RES

+;; initializes the value of the result list.  INVERT-P indicates

+;; whether to invert the test-form used to determine how the result

+;; should be updated.

+(defmacro nprocess-set (init-res invert-p)

+  `(let ((hashtable (list-to-hashtable list2 key test test-not)))

+     (if hashtable

+         (nprocess-set-body ,init-res ,invert-p

+                            (nth-value 1 (gethash (apply-key key (car list1)) hashtable)))

+         (nprocess-set-body ,init-res ,invert-p

+                            (with-set-keys (member (apply-key key (car list1)) list2))))))

+

+

 (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))

   "Destructively returns the union list1 and list2."

   (declare (inline member))

   (if (and testp notp)

       (error "Test and test-not both supplied."))

-  (let ((res list2)

-	(list1 list1))

-    (do ()

-	((endp list1))

-      (if (not (with-set-keys (member (apply-key key (car list1)) list2)))

-	  (steve-splice list1 res)

-	  (setf list1 (cdr list1))))

-    res))

+

+  (nprocess-set list2 t))

 (defun nintersection (list1 list2 &key key

 			    (test #'eql testp) (test-not nil notp))

   (declare (inline member))

   (if (and testp notp)

       (error "Test and test-not both supplied."))

-  (let ((res nil)

-	(list1 list1))

-    (do () ((endp list1))

-      (if (with-set-keys (member (apply-key key (car list1)) list2))

-	  (steve-splice list1 res)

-	  (setq list1 (Cdr list1))))

-    res))

+

+  (nprocess-set nil nil))

 (defun nset-difference (list1 list2 &key key

 			      (test #'eql testp) (test-not nil notp))

   (declare (inline member))

   (if (and testp notp)

       (error "Test and test-not both supplied."))

-  (let ((res nil)

-	(list1 list1))

-    (do () ((endp list1))

-      (if (not (with-set-keys (member (apply-key key (car list1)) list2)))

-	  (steve-splice list1 res)

-	  (setq list1 (cdr list1))))

-    res))

+  (nprocess-set nil t))

+

+(declaim (end-block))

 (defun set-exclusive-or (list1 list2 &key key

                          (test #'eql testp) (test-not nil notp))

 				:test 'eql

 				:test-not 'eql)))

-   

+(define-test nset-diff.1

+    (:tag :issues)

+  ;; From CLHS

+  (flet 

+      ((test1 (min-length-limit)

+         (let ((lisp::*min-list-length-for-hashtable* min-length-limit)

+               (lst1 (list "A" "b" "C" "d"))

+               (lst2 (list "a" "B" "C" "d")))

+           (assert-equal '("b" "A")

+                         (nset-difference lst1 lst2 :test 'equal))

+           ;; This isn't specified by the CLHS, but it is what we do.

+           (assert-equal '("A") lst1))))

+    (test1 100)

+    (test1 1)))

+

+(define-test nset-diff.key

+    (:tag :issues)

+  (flet

+      ((test (min-length-limit)

+         ;; From CLHS

+         (let ((lisp::*min-list-length-for-hashtable* min-length-limit)

+               (lst1 (list '("a" . "b") '("c" . "d") '("e" . "f")))

+               (lst2 (list '("c" . "a") '("e" . "b") '("d" . "a"))))

+           (assert-equal '(("e" . "f") ("c" . "d"))

+                         (nset-difference lst1 lst2 :test 'equal :key #'cdr))

+           ;; This isn't specified by the CLHS, but it is what we do.

+           (assert-equal '(("a" . "b") ("c" . "d")) lst1))))

+    (test 100)

+    (test 1)))

+  

 (define-test union.hash-eql

     (:tag :issues)

   ;; For union to use hashtables by making the threshold

 		       :test 'eql

 		       :test-not 'eql)))

+(define-test nunion.1

+    (:tag :issues)

+  (flet

+      ((test (min-list-length)

+         (let ((lisp::*min-list-length-for-hashtable* min-list-length)

+               (lst1 (list 1 2 '(1 2) "a" "b"))

+               (lst2 (list 2 3 '(2 3) "B" "C")))

+           (assert-equal '("b" "a" (1 2) 1 2 3 (2 3) "B" "C")

+                         (nunion lst1 lst2))

+           (assert-equal '(1 2 3 (2 3) "B" "C")

+                         lst1))))

+    (test 100)

+    (test 1)))

+

+(define-test nintersection.1

+    (:tag :issues)

+  (flet

+      ((test (min-list-length)

+         (let ((lisp::*min-list-length-for-hashtable* min-list-length)

+               (lst1 (list 1 1 2 3 4 'a 'b 'c "A" "B" "C" "d"))

+               (lst2 (list 1 4 5 'b 'c 'd "a" "B" "c" "D")))

+           (assert-equal '(c b 4 1 1)

+                         (nintersection lst1 lst2))

+           (assert-equal '(1) lst1))))

+    (test 100)

+    (test 1)))

+

 (define-test subsetp.hash-eq

     (:tag :issues)

Raymond Toy pushed to branch issue-240-add-hashtable-set-exclusive-or at cmucl / cmucl

Commits:

2 changed files:

Changes: