From 24a83301783adcc392f942ba8aa30c3ad082d5cc Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Sat, 23 Jul 2022 12:49:55 -0700
Subject: Add set library.

This will maybe be useful for live variable analysis.
---
 csc/set.csc | 158 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 158 insertions(+)
 create mode 100644 csc/set.csc

(limited to 'csc/set.csc')

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))))))
-- 
cgit v1.3.1