From 50f99976e0ba8de4ee03e6fa92498c50b75e57c0 Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Tue, 24 Dec 2019 12:31:12 +0000
Subject: Support set/{reduce,intersection,equal?,distinct?}

Adds additional functions for the set.el module. See the function documentation
and tests for more information.
---
 configs/shared/.emacs.d/wpc/set.el | 82 ++++++++++++++++++++++++++++++--------
 1 file changed, 66 insertions(+), 16 deletions(-)

(limited to 'configs/shared/.emacs.d/wpc/set.el')

diff --git a/configs/shared/.emacs.d/wpc/set.el b/configs/shared/.emacs.d/wpc/set.el
index fd86f9033cc3..031a03806b48 100644
--- a/configs/shared/.emacs.d/wpc/set.el
+++ b/configs/shared/.emacs.d/wpc/set.el
@@ -23,6 +23,9 @@
 
 (cl-defstruct set xs)
 
+(defconst set/enable-testing? t
+  "Run tests when t.")
+
 (defun set/from-list (xs)
   "Create a new set from the list XS."
   (make-set :xs (->> xs
@@ -45,10 +48,26 @@
                  xs
                  (lambda (table)
                    (let ((table-copy (ht-copy table)))
-                     (ht-set table-copy x 10)
+                     (ht-set table-copy x nil)
                      table-copy))
                  xs))
 
+;; TODO: Ensure all `*/reduce' functions share the same API.
+(defun set/reduce (acc f xs)
+  "Return a new set by calling F on each element of XS and ACC."
+  (->> xs
+       set/to-list
+       (list/reduce acc f)))
+
+(defun set/intersection (a b)
+  "Return the set intersection between sets A and B."
+  (set/reduce (set/new)
+              (lambda (x acc)
+                (if (set/contains? x b)
+                    (set/add x acc)
+                  acc))
+              a))
+
 (defun set/count (xs)
   "Return the number of elements in XS."
   (->> xs
@@ -67,26 +86,57 @@
   "Return t if set XS has X."
   (ht-contains? (set-xs xs) x))
 
+;; TODO: Prefer using `ht.el' functions for this.
+(defun set/equal? (a b)
+  "Return t if A and B share the name members."
+  (ht-equal? (set-xs a)
+             (set-xs b)))
+
+(defun set/distinct? (a b)
+  "Return t if sets A and B have no shared members."
+  (set/empty? (set/intersection a b)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Tests
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defconst set/enable-testing? t
-  "Run tests when t.")
-
 (when set/enable-testing?
-  (progn
-    ;; {from,to}-list
-    (prelude/assert (equal '(1 2 3)
-                           (->> '(1 1 2 2 3 3)
-                                set/from-list
-                                set/to-list)))
-    ;; empty?
-    (prelude/assert (set/empty? (set/new)))
-    (prelude/refute (set/empty? (set/new 1 2 3)))
-    ;; count
-    (prelude/assert (= 0 (set/count (set/new))))
-    (prelude/assert (= 2 (set/count (set/new 1 1 2 2))))))
+  ;; set/distinct?
+  (prelude/assert
+   (set/distinct? (set/new 'one 'two 'three)
+                  (set/new 'a 'b 'c)))
+  (prelude/refute
+   (set/distinct? (set/new 1 2 3)
+                  (set/new 3 4 5)))
+  (prelude/refute
+   (set/distinct? (set/new 1 2 3)
+                  (set/new 1 2 3)))
+  ;; set/equal?
+  (prelude/refute
+   (set/equal? (set/new 'a 'b 'c)
+               (set/new 'x 'y 'z)))
+  (prelude/refute
+   (set/equal? (set/new 'a 'b 'c)
+               (set/new 'a 'b)))
+  (prelude/assert
+   (set/equal? (set/new 'a 'b 'c)
+               (set/new 'a 'b 'c)))
+  ;; set/intersection
+  (prelude/assert
+   (set/equal? (set/new 2 3)
+               (set/intersection (set/new 1 2 3)
+                                 (set/new 2 3 4))))
+  ;; set/{from,to}-list
+  (prelude/assert (equal '(1 2 3)
+                         (->> '(1 1 2 2 3 3)
+                              set/from-list
+                              set/to-list)))
+  ;; set/empty?
+  (prelude/assert (set/empty? (set/new)))
+  (prelude/refute (set/empty? (set/new 1 2 3)))
+  ;; set/count
+  (prelude/assert (= 0 (set/count (set/new))))
+  (prelude/assert (= 2 (set/count (set/new 1 1 2 2)))))
 
 (provide 'set)
 ;;; set.el ends here
-- 
cgit 1.4.1