branch: externals/hyperbole
commit 7853de7dec0b3e7f11f60ce48fd06ab8b6c56967
Author: Bob Weiner <[email protected]>
Commit: Bob Weiner <[email protected]>
Add Mats set-tests.el with updates and update set.el
---
ChangeLog | 9 ++++
set.el | 107 +++++++++++++++++++++++++---------------
test/MANIFEST | 1 +
test/set-tests.el | 143 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 222 insertions(+), 38 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 0e2b9a7484..7aa6884bd4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2023-02-06 Bob Weiner <[email protected]>
+
+* set.el (set:member): Optimize for common equality operators.
+ (set:add, set:remove): Convert from a macro to a function and
optimize.
+ (set:replace): Rename to 'set:replace-key-value' and use 'set:replace'
+ to replace a non-keyed old-value with a new value.
+ (set:members): Keep members in stable order; previously returned in
+ reverse order.
+
2023-02-05 Bob Weiner <[email protected]>
* hyrolo.el (hyrolo-initialize-file-list): Fix to not overwrite any user
customized
diff --git a/set.el b/set.el
index e971fc769c..aa9962cb4d 100644
--- a/set.el
+++ b/set.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 26-Sep-91 at 19:24:19
-;; Last-Mod: 6-Aug-22 at 23:23:08 by Mats Lidell
+;; Last-Mod: 6-Feb-23 at 01:57:00 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -23,6 +23,7 @@
;; a new set with the single member, 'element.
;;; Code:
+
;; ************************************************************************
;; Public variables
;; ************************************************************************
@@ -33,42 +34,54 @@ It must be a function of two arguments which returns
non-nil only when
the arguments are equivalent.")
;; ************************************************************************
-;; Public macros
+;; Public functions
;; ************************************************************************
+(defun set:add (elt set)
+ "Add element ELT to SET and then return SET.
+Uses `set:equal-op' for comparison.
+Use (setq set (set:add elt set)) to assure set is always properly modified."
+ (cond ((set:member elt set) set)
+ ((listp set) (setq set (cons elt set)))
+ (t (list elt))))
+
(defun set:member (elt set)
"Return non-nil if ELT is an element of SET.
The value is actually the tail of SET whose car is ELT.
Uses `set:equal-op' for comparison."
- (while (and set (not (funcall set:equal-op elt (car set))))
- (setq set (cdr set)))
- set)
-
-(defmacro set:add (elt set)
- "Add element ELT to SET and then return SET, even if SET is nil.
-Uses `set:equal-op' for comparison.
-Use (setq set (set:add elt set)) to assure set is always properly modified."
- `(cond ((set:member ,elt ,set) ,set)
- (,set (setq ,set (cons ,elt ,set)))
- (t (list ,elt))))
-
-(defmacro set:remove (elt set)
+ (pcase set:equal-op
+ ('equal (member elt set))
+ ('eq (memq elt set))
+ ('eql (memql elt set))
+ (_ (while (and set (not (funcall set:equal-op elt (car set))))
+ (setq set (cdr set)))
+ set)))
+
+(defun set:remove (elt set)
"Remove element ELT from SET and return new set.
Assume SET is a valid set. Uses `set:equal-op' for comparison.
Use (setq set (set:remove elt set)) to assure set is always properly modified."
- `(let ((rest (set:member ,elt ,set))
- (rtn ,set))
- (if rest
- (cond ((= (length rtn) 1) (setq rtn nil))
- ((= (length rest) 1)
- (setcdr (nthcdr (- (length rtn) 2) rtn) nil))
- (t (setcar rest (car (cdr rest)))
- (setcdr rest (cdr (cdr rest))))))
- rtn))
+ (pcase set:equal-op
+ ('equal (delete elt set))
+ ((or 'eq 'eql) (delq elt set))
+ (_ (let ((rest (set:member elt set))
+ (rtn set))
+ (when rest
+ (cond ((= (length rtn) 1) (setq rtn nil))
+ ((= (length rest) 1)
+ (setcdr (nthcdr (- (length rtn) 2) rtn) nil))
+ (t (setcar rest (cadr rest))
+ (setcdr rest (cddr rest)))))
+ rtn))))
+
+(defun set:remove-key-value (key set)
+ "Remove element whose car matches KEY in SET.
+Return the set. Use (setq set (set:remove-key-value key set)) to assure set is
+always properly modified.
-;; ************************************************************************
-;; Public functions
-;; ************************************************************************
+Use `set:equal-op' to match against KEY. Assume each element in the set has a
+car and a cdr."
+ (assoc-delete-all key set set:equal-op))
(defun set:combinations (set &optional arity)
"Return all possible combinations (subsets) of SET.
@@ -88,7 +101,8 @@ members."
(setq rest (nthcdr ctr set)
ctr (1+ ctr))
(mapcar (lambda (elt)
- (if (listp elt) (cons first elt)
+ (if (listp elt)
+ (cons first elt)
(list first elt)))
(set:combinations rest (1- arity))))
set))))))
@@ -98,10 +112,13 @@ members."
"Return a new set created from any number of ELEMENTS.
If no ELEMENTS are given, return the empty set. Uses `set:equal-op'
for comparison."
- (let ((set))
- (mapc (lambda (elt) (or (set:member elt set) (setq set (cons elt set))))
- elements)
- (nreverse set)))
+ (pcase set:equal-op
+ ('equal (delete-dups elements))
+ (_ (let ((set))
+ (mapc (lambda (elt) (unless (set:member elt set)
+ (setq set (cons elt set))))
+ elements)
+ (nreverse set)))))
(defalias 'set:delete 'set:remove)
(defun set:difference (&rest sets)
@@ -113,7 +130,7 @@ other sets. Uses `set:equal-op' for comparison."
(mapc (lambda (elem) (setq rtn-set (set:remove elem rtn-set)))
set))
(cdr sets))
- (nreverse rtn-set)))
+ rtn-set))
(defalias 'set:size 'length)
@@ -161,12 +178,26 @@ Uses `set:equal-op' for comparison. See also
`set:create'."
(let ((set))
(mapc (lambda (elt) (or (set:member elt set) (setq set (cons elt set))))
list)
- set))
+ (nreverse set)))
+
+(defun set:replace (old-elt new-elt set)
+ "Replace OLD-ELT with NEW-ELT in SET. Add NEW-ELT if OLD-ELT is not in SET.
+Return the set. Use (setq set (set:replace elt set)) to assure set is
+always properly modified.
+
+Use `set:equal-op' for element comparisons."
+ (let ((elt-set (set:member old-elt set)))
+ (if elt-set
+ ;; replace element
+ (progn (setcar elt-set new-elt)
+ set)
+ ;; add new element
+ (cons new-elt set))))
-(defun set:replace (key value set)
- "Replace or add element whose car matches KEY with element (KEY . VALUE) in
SET.
-Return set if modified, else nil.
-Use (setq set (set:replace elt set)) to assure set is always properly modified.
+(defun set:replace-key-value (key value set)
+ "Replace or add element whose car matches KEY with a cdr of VALUE in SET.
+Return the set. Use (setq set (set:replace elt set)) to assure set is
+always properly modified.
Use `set:equal-op' to match against KEY. Assume each element in the set has a
car and a cdr."
diff --git a/test/MANIFEST b/test/MANIFEST
index 2700c67646..818c61174c 100644
--- a/test/MANIFEST
+++ b/test/MANIFEST
@@ -19,4 +19,5 @@ hy-test-helpers.el - unit test helpers
kexport-tests.el - kexport tests
kotl-mode-tests.el - kotl-mode-el tests
kotl-orgtbl-tests.el - kotl orgtbl tests
+set-tests.el - mathematical set library tests
smart-org-tests.el - smart-org-el tests
diff --git a/test/set-tests.el b/test/set-tests.el
new file mode 100644
index 0000000000..7cb920772a
--- /dev/null
+++ b/test/set-tests.el
@@ -0,0 +1,143 @@
+;;; set-tests.el --- Hyperbole mathematical set library tests -*-
lexical-binding: t; -*-
+;;
+;; Author: Mats Lidell
+;;
+;; Orig-Date: 5-Feb-23 at 09:12:52
+;; Last-Mod: 6-Feb-23 at 02:06:27 by Bob Weiner
+;;
+;; SPDX-License-Identifier: GPL-3.0-or-later
+;;
+;; Copyright (C) 2021-2022 Free Software Foundation, Inc.
+;; See the "HY-COPY" file for license information.
+;;
+;; This file is part of GNU Hyperbole.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'set)
+
+(ert-deftest set-tests--function-tests ()
+ "Test Hyperbole set library functions."
+ (should (set:equal (set:create) nil))
+ (should (set:empty (set:create)))
+ (should-not (set:empty (set:create 'a)))
+
+ (should (set:is (set:create)))
+ (should (set:is (set:create 'a)))
+ (should-not (set:is "string is not a set"))
+ (should-not (set:is 'symbol-is-not-a-set))
+ (should-not (set:is 1))
+ (should-not (set:is '(a a)))
+
+ (should (= (set:size (set:create)) 0))
+ (should (= (set:size (set:create 'a)) 1))
+ (should (= (set:size (set:create 'a 'b)) 2))
+ (should (= (set:size (set:create 'a 'a)) 1))
+
+ (should (set:equal (set:create) (set:create)))
+ (should (set:equal (set:create 'a) (set:create 'a)))
+ (should (set:equal (set:create 'b 'a) (set:create 'a 'b)))
+
+ (should (set:equal (set:member 'a (set:create 'a)) (set:create 'a)))
+ (should (set:equal (set:member 'a (set:create 'a 'b)) (set:create 'a 'b)))
+ (should (set:equal (set:member 'b (set:create 'a 'b)) (set:create 'b)))
+ (should (set:empty (set:member 'c (set:create 'a))))
+
+ (should (set:is (set:combinations (set:create 'a 'b 'c))))
+ (should (set:equal (set:combinations (set:create 'a)) '(nil a)))
+ (should (set:equal (set:combinations (set:create 'a 'b)) '(nil a b (a b))))
+ (should (set:equal (set:combinations (set:create 'a 'b 'c))
+ '(nil a b c (a b) (a c) (b c) (a b c))))
+
+ (should (set:empty (set:intersection (set:create) (set:create))))
+ (should (set:empty (set:intersection (set:create) (set:create 'a))))
+ (should (set:empty (set:intersection (set:create 'a) (set:create 'c))))
+ (should (set:equal (set:intersection (set:create 'a) (set:create 'a))
+ (set:create 'a)))
+ (should (set:equal (set:intersection (set:create 'a 'b) (set:create 'a))
+ (set:create 'a)))
+ (should (set:equal (set:intersection (set:create 'a 'b) (set:create 'a 'c)
(set:create 'a 'd))
+ (set:create 'a)))
+
+ (should (set:empty (set:difference (set:create) (set:create))))
+ (should (set:empty (set:difference (set:create 'a) (set:create 'a))))
+ (should (set:empty (set:difference (set:create) (set:create 'a))))
+ (should (set:equal (set:difference (set:create 'a) (set:create))
+ (set:create 'a)))
+ (should (set:equal (set:difference (set:create 'a) (set:create 'c))
+ (set:create 'a)))
+ (should (set:equal (set:difference (set:create 'a 'b) (set:create 'a))
+ (set:create 'b)))
+ (should (set:empty (set:difference (set:create 'a 'b) (set:create 'a)
(set:create 'b))))
+
+ (should (set:empty (set:union (set:create) (set:create))))
+ (should (set:equal (set:union (set:create 'a) (set:create))
+ (set:create 'a)))
+ (should (set:equal (set:union (set:create 'a) (set:create 'a))
+ (set:create 'a)))
+ (should (set:equal (set:union (set:create 'a) (set:create 'b))
+ (set:create 'a 'b)))
+ (should (set:equal (set:union (set:create 'a) (set:create 'b) (set:create
'c))
+ (set:create 'a 'b 'c)))
+
+ (should (set:empty (set:difference (set:create) (set:create 'a))))
+ (should (set:empty (set:difference (set:create 'a) (set:create 'a))))
+ (should (set:equal (set:difference (set:create 'a) (set:create))
+ (set:create 'a)))
+ (should (set:equal (set:difference (set:create 'a) (set:create 'c))
+ (set:create 'a)))
+ (should (set:equal (set:difference (set:create 'a 'b) (set:create 'a))
+ (set:create 'b)))
+ (should (set:empty (set:difference (set:create 'a 'b) (set:create 'a)
(set:create 'b))))
+
+ (should (set:subset (set:create) (set:create)))
+ (should (set:subset (set:create) (set:create 'a)))
+ (should (set:subset (set:create 'a) (set:create 'a)))
+ (should-not (set:subset (set:create 'a) (set:create 'b)))
+
+ (should (set:equal (set:add 'a (set:create)) (set:create 'a)))
+ (should (set:equal (set:add 'a (set:create 'a)) (set:create 'a)))
+ ;; Adding a list as an element in a set
+ (should (set:equal (set:add '(b c) (set:create 'a)) (set:create 'a '(b c))))
+
+ (should (set:empty (set:remove 'a (set:create 'a))))
+ (should (set:equal (set:remove 'a (set:create 'b)) (set:create 'b)))
+ (should (set:equal (set:remove 'a (set:create 'a 'b)) (set:create 'b)))
+ (should-not (set:equal (set:remove 'a (set:create 'a 'b)) (set:create 'a
'b)))
+
+ ;; FIXME: Need to add tests for (set:remove-key-value key set)
+
+ ;; set:get - requires elements to be of type (key . value)
+ (should (equal (set:get 'a (set:create (cons 'a 'value-a))) 'value-a))
+ (should (equal (set:get 'b (set:create (cons 'a 'value-a))) nil))
+
+ ;; FIXME: Need to add tests for (set:replace old-val new-val set)
+
+ ;; set:replace-key-value - requires elements to be of type (key . value)
+ (should (set:equal (set:replace-key-value 'a 'new-value-a (set:create (cons
'a 'value-a)))
+ (set:create '(a . new-value-a) '(a . value-a))))
+ (should (set:equal (set:replace-key-value 'b 'new-value-b (set:create (cons
'a 'value-a)))
+ (set:create '(b . new-value-b) '(a . value-a))))
+ (let ((set (set:create (cons 'a 'value-a))))
+ (setq set (set:replace-key-value 'a 'new-value-a set))
+ (should (set:equal set (set:create '(a . new-value-a) '(a . value-a)))))
+
+ ;; set:members works on lists!?
+ ;; FIXME: Use verification that list contains elements rather than checking
+ ;; a specific order
+ (should (equal (set:members '(1)) '(1)))
+ (should (equal (set:members '(1 2)) '(1 2)))
+ (should (equal (set:members '(1 1)) '(1)))
+ (should (equal (set:members '(1 1 2 2)) '(1 2))))
+
+(ert-deftest set-tests--equal-op-tests ()
+ "Test Hyperbole set library functions with equal op always true."
+ (let ((set:equal-op (lambda (_x _y) t)))
+ (should (= (set:size (set:create 'a 'b)) 1))
+ (should (= (set:size (set:union (set:create 'a) (set:create 'b))) 1))
+ (should (set:equal (set:union (set:create 'a) (set:create 'b)) (set:create
'a)))))
+
+(provide 'set-tests)
+;;; set-tests.el ends here
