Add set on top of tree-table.tree

1 files changed, 46 insertions, 0 deletions

diff --git a/module/hnh/util/set.scm b/module/hnh/util/set.scm
new file mode 100644
index 00000000..2839a231
--- /dev/null
+++ b/module/hnh/util/set.scm
@@ -0,0 +1,46 @@
+(define-module (hnh util set)
+  :use-module (hnh util object)
+  :use-module (hnh util table))
+
+(define-type (set)
+  (set-data default: (make-table)))
+
+(define (set-null) (set))
+
+(define (set-adjoin value set)
+  (modify set set-data tree-put value #t))
+
+(define (set-disjoin value set)
+  (modify set set-data tree-put value #f))
+
+(define (in-set? set value)
+  (catch 'out-of-range
+    (lambda () (tree-get (set-data set) value))
+    (lambda () #f)))
+
+(define (set-fold f done set)
+  (tree-fold (lambda (k v lst)
+               (if v
+                   (f k done)
+                   done))
+             done set))
+
+(define (set->list set)
+  (set-fold cons '() set))
+
+(define (set-union set1 set2)
+  (set-fold set-adjoin set1 set2))
+
+(define (set-intersection set1 set2)
+  (set-fold (lambda (v set)
+              (if (in-set? v set1)
+                  set1
+                  (set-disjoin v set1)))
+            set1 set2))
+
+(define (set-difference set1 set2)
+  (set-fold set-disjoin set1 set2))
+
+;; (define (set-xor set1 set2))
+
+