Add set library.

This will maybe be useful for live variable analysis.

2 files changed, 334 insertions, 0 deletions

diff --git a/csc/set-test.csc b/csc/set-test.csc
new file mode 100644
index 0000000..32b16fc
--- /dev/null
+++ b/csc/set-test.csc
@@ -0,0 +1,176 @@
+(import (scheme base)
+        (only (csc hash-map)
+          hash-bytevector)
+        (only (csc sort)
+          sort)
+        (only (csc testing)
+          assert-equal)
+        (csc set))
+
+
+(define transform-set
+  (cons set? (lambda (s)
+               (sort (lambda (x y)
+                       (string<? (symbol->string x) (symbol->string y)))
+                 (set->list s)))))
+
+
+(define k
+  (make-comparer
+    (lambda (s)
+      (hash-bytevector (string->utf8 (symbol->string s))))
+    (lambda (x y)
+      (cond
+        ((symbol=? x y) 0)
+        ((string<? (symbol->string x) (symbol->string y)) -1)
+        (else 1)))))
+
+
+(test difference
+  (assert-equal
+    '(a c e)
+    (difference
+      (set k 'a 'b 'c 'd 'e)
+      (set k 'b 'd))
+    transform-set))
+
+
+(test difference-empty
+  (assert-equal
+    '(a b c d e)
+    (difference
+      (set k 'a 'b 'c 'd 'e)
+      *empty-set*)
+    transform-set))
+
+
+(test difference-empty2
+  (assert-equal
+    '()
+    (difference
+      *empty-set*
+      (set k 'a 'b 'c 'd 'e))
+    transform-set))
+
+
+(test empty-yes
+  (assert-equal
+    #t
+    (empty? *empty-set*)))
+
+
+(test empty-map
+  (assert-equal
+    #t
+    (empty? (set k))))
+
+
+(test empty-no
+  (assert-equal
+    #f
+    (empty? (set k 'a))))
+
+
+(test intersection
+  (assert-equal
+    '(d e)
+    (intersection
+      (set k 'a 'b 'c 'd 'e)
+      (set k 'd 'e 'f 'g 'h))
+    transform-set))
+
+(test intersection-empty
+  (assert-equal
+    '()
+    (intersection
+      (set k 'a 'b 'c 'd 'e)
+      *empty-set*)
+    transform-set))
+
+
+(test member-yes
+  (assert-equal
+    #t
+    (member? 'b (set k 'a 'b 'c))))
+
+
+(test member-no
+  (assert-equal
+    #f
+    (member? 'd (set k 'a 'b 'c))))
+
+
+(test member-empty
+  (assert-equal
+    #f
+    (member? 'a *empty-set*)))
+
+
+(test set=?-yes
+  (assert-equal
+    #t
+    (set=? (set k 'a 'b 'c) (set k 'a 'b 'c))))
+
+
+(test set=?-no
+  (assert-equal
+    #f
+    (set=? (set k 'a 'b 'c) (set k 'a 'b))))
+
+
+(test set=?-empty
+  (assert-equal
+    #t
+    (set=? *empty-set* (set k))))
+
+
+(test subset-yes
+  (assert-equal
+    #t
+    (subset?
+      (set k 'b 'c)
+      (set k 'a 'b 'c 'd))))
+
+
+(test subset-no
+  (assert-equal
+    #f
+    (subset?
+      (set k 'd 'e)
+      (set k 'a 'b 'c 'd))))
+
+
+(test subset-empty
+  (assert-equal
+    #t
+    (subset? *empty-set* *empty-set*)))
+
+
+(test subset-of-empty
+  (assert-equal
+    #f
+    (subset? (set k 'a) *empty-set*)))
+
+
+(test subset-another-empty
+  (assert-equal
+    #t
+    (subset? *empty-set* (set k))))
+
+
+(test union
+  (assert-equal
+    '(a b c d e f g h i)
+    (union
+      (set k 'a 'b 'c)
+      (set k 'd 'e 'f)
+      (set k 'g 'h 'i))
+    transform-set))
+
+
+(test union-empty
+  (assert-equal
+    '(a b c)
+    (union
+      (set k 'a 'b 'c)
+      *empty-set*)))
diff --git a/csc/set.csc b/csc/set.csc
new file mode 100644
index 0000000..3cc270e
--- /dev/null
+++ b/csc/set.csc
@@ -0,0 +1,158 @@
+(define-library (csc set)
+  (export
+    *empty-set*
+    difference
+    empty?
+    intersection
+    make-comparer
+    member?
+    set
+    set->list
+    set=?
+    set?
+    subset?
+    union)
+  (import (scheme base)
+          (only (csc hash-map)
+            delete
+            insert
+            lookup
+            make-map
+            map-for-each
+            map?
+            merge)
+          (only (csc loop)
+            loop
+            return))
+  (begin
+
+
+    (define-record-type <empty-set>
+      (make-empty-set)
+      empty-set?)
+
+
+    (define *empty-set* (make-empty-set))
+
+
+    (define (set? x)
+      (or (map? x)
+          (empty-set? x)))
+
+
+    (define-record-type <not-empty>
+      (make-not-empty)
+      not-empty?)
+
+
+    (define *not-empty* (make-not-empty))
+
+
+    (define (empty? s)
+      (or (empty-set? s)
+          (guard (e ((not-empty? e) #f))
+            (map-for-each (lambda (k v)
+                            (raise *not-empty*))
+              s)
+            #t)))
+
+
+    (define-record-type <comparer>
+      (make-comparer hash cmp)
+      comparer?
+      (hash comparer-hash)
+      (cmp comparer-cmp))
+
+
+    (define (set k . l)
+      (loop with m = (make-map (comparer-hash k) (comparer-cmp k))
+            for x in l
+            do (set! m (insert m x #t))
+            finally (return m)))
+
+
+    (define (member? x s)
+      (and (not (empty-set? s))
+           (lookup s x #f)))
+
+
+    (define (union . s*)
+      (define non-empty (loop for s in s*
+                              unless (empty-set? s)
+                                collect s))
+      (if (null? non-empty)
+        *empty-set*
+        (apply merge non-empty)))
+
+
+    (define (intersect2 s1 s2)
+      (map-for-each (lambda (k v)
+                      (unless (member? k s2)
+                        (set! s1 (delete s1 k))))
+        s1)
+      s1)
+
+
+    (define (intersection . s*)
+      (if (or (loop for s in s*
+                    if (empty-set? s)
+                      return #t
+                    finally (return #f))
+              (null? s*))
+        *empty-set*
+        (loop for s in s*
+              for result = s then (intersect2 result s)
+              finally (return result))))
+
+
+    (define (difference s1 s2)
+      (cond
+        ((empty? s2) s1)
+        ((empty? s1) *empty-set*)
+        (else
+          (map-for-each (lambda (k v)
+                          (set! s1 (delete s1 k)))
+            s2)
+          s1)))
+
+
+    (define-record-type <not-subset>
+      (make-not-subset)
+      not-subset?)
+
+
+    (define *not-subset* (make-not-subset))
+
+
+    (define (subset? s1 s2)
+      (cond
+        ((empty? s1) #t)
+        ((empty? s2) #f)
+        (else
+          (guard (e ((not-subset? e) #f))
+            (map-for-each (lambda (k v)
+                            (unless (member? k s2)
+                              (raise *not-subset*)))
+              s1)
+            #t))))
+
+
+    (define (set->list s)
+      (if (empty-set? s)
+        '()
+        (let ((l '()))
+          (map-for-each (lambda (k v)
+                          (set! l (cons k l)))
+            s)
+          l)))
+
+
+    (define (set=? . s*)
+      (if (null? s*)
+        #t
+        (loop with s1 = (car s*)
+              for s in (cdr s*)
+              unless (and (subset? s s1)
+                          (subset? s1 s))
+                return #f
+              finally (return #t))))))