Skip to content
Snippets Groups Projects
Commit ffe3625a authored by Raymond Toy's avatar Raymond Toy
Browse files

Address #240: Rename processing macros for set operations

parent 4542d55e
Branches
Tags
1 merge request!171Address #240: Rename processing macros for set operations
......@@ -753,26 +753,31 @@
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.
;; TEST-FORM is a form that tests whether to add the item from LIST1
;; to RES.
(defmacro process-set-body (init-res invert-p test-form)
;; Handle a non-destructive set operation. LIST1 and LIST2 are the
;; two arguments to the set function. INITIAL-RESULT is the value
;; used to initialize the result list. IS specifies whether the test
;; (or test-not) function implies an element of LIST1 should be
;; included in the result.
(defmacro do-set-operation (list1 list2 &key initial-result is)
(let ((membership-test (ecase is
(:element-of-set
'when)
(:not-element-of-set
'unless))))
`(let ((hashtable (list-to-hashtable ,list2 key test test-not)))
(macrolet
((process-set-op (list1 init-res member-form test-form)
`(let ((res ,init-res))
(dolist (item list1)
(when ,(if invert-p
`(not ,test-form)
test-form)
(dolist (item ,list1)
(,member-form ,test-form
(push item res)))
res))
res)))
(defmacro process-set (init-res invert-p)
`(let ((hashtable (list-to-hashtable list2 key test test-not)))
(if hashtable
(process-set-body ,init-res ,invert-p
(process-set-op ,list1 ,initial-result ,membership-test
(nth-value 1 (gethash (apply-key key item) hashtable)))
(process-set-body ,init-res ,invert-p
(with-set-keys (member (apply-key key item) list2))))))
(process-set-op ,list1 ,initial-result ,membership-test
(with-set-keys (member (apply-key key item) list2))))))))
;; Convert a list to a hashtable. The hashtable does not handle
;; duplicated values in the list. Returns the hashtable.
......@@ -815,7 +820,7 @@
(declare (inline member))
(when (and testp notp)
(error (intl:gettext "Test and test-not both supplied.")))
(process-set list2 t))
(do-set-operation list1 list2 :initial-result list2 :is :not-element-of-set))
(defun intersection (list1 list2 &key key
......@@ -824,7 +829,7 @@
(declare (inline member))
(if (and testp notp)
(error "Test and test-not both supplied."))
(process-set nil nil))
(do-set-operation list1 list2 :initial-result nil :is :element-of-set))
(defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp))
"Returns the elements of list1 which are not in list2."
......@@ -835,7 +840,7 @@
(when (null list2)
(return-from set-difference list1))
(process-set nil t))
(do-set-operation list1 list2 :initial-result nil :is :not-element-of-set))
;;; Destination and source are setf-able and many-evaluable. Sets the source
......@@ -851,14 +856,14 @@
;;; 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)
(defmacro nprocess-set-body (list1 init-res is-member-p test-form)
`(let ((res ,init-res)
(list1 list1))
(list1 ,list1))
(do ()
((endp list1))
(if ,(if invert-p
`(not ,test-form)
test-form)
(if ,(if is-member-p
test-form
`(not ,test-form))
(steve-splice list1 res)
(setq list1 (cdr list1))))
res))
......@@ -867,13 +872,30 @@
;; 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)))
(defmacro do-destructive-set-operation (list1 list2 &key initial-result is)
(let ((is-member-p (ecase is
(:element-of-set
t)
(:not-element-of-set
nil))))
`(let ((hashtable (list-to-hashtable ,list2 key test test-not)))
(macrolet
((process-set-op (list1 init-res is-member-p test-form)
`(let ((res ,init-res)
(list1 ,list1))
(do ()
((endp list1))
(if ,(if is-member-p
test-form
`(not ,test-form))
(steve-splice list1 res)
(setq list1 (cdr list1))))
res)))
(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))))))
(process-set-op ,list1 ,initial-result ,is-member-p
(nth-value 1 (gethash (apply-key key (car ,list1)) hashtable)))
(process-set-op ,list1 ,initial-result ,is-member-p
(with-set-keys (member (apply-key key (car ,list1)) list2))))))))
(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
......@@ -882,7 +904,7 @@
(if (and testp notp)
(error "Test and test-not both supplied."))
(nprocess-set list2 t))
(do-destructive-set-operation list1 list2 :initial-result list2 :is :not-element-of-set))
(defun nintersection (list1 list2 &key key
(test #'eql testp) (test-not nil notp))
......@@ -891,7 +913,7 @@
(if (and testp notp)
(error "Test and test-not both supplied."))
(nprocess-set nil nil))
(do-destructive-set-operation list1 list2 :initial-result nil :is :element-of-set))
(defun nset-difference (list1 list2 &key key
(test #'eql testp) (test-not nil notp))
......@@ -900,7 +922,7 @@
(if (and testp notp)
(error "Test and test-not both supplied."))
(nprocess-set nil t))
(do-destructive-set-operation list1 list2 :initial-result nil :is :not-element-of-set))
(declaim (end-block))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please to comment