Initial implementation of slsets egg

This implements sets of symbols *as lists*, like in the srfi-1 lset
operations.  It maintains the benefit of using lists for everything,
but not having to pay the quadratic performance penalty that srfi-1
entails.  We achieve this by using plist operations to "mark" items
so we have to visit the list "set" only a fixed number of times.

1 files changed, 155 insertions, 0 deletions

diff --git a/slsets.scm b/slsets.scm
new file mode 100644
index 0000000..aef229f
--- /dev/null
+++ b/slsets.scm
@@ -0,0 +1,155 @@
+;;
+;; Lists of symbols as sets
+;;
+;; Essentially, this provides specialized versions of SRFI-1's lset
+;; operations for symbols but with linear instead of quadratic time
+;; complexity.  It's even faster than using a side hash table, unless
+;; the symbols already have large plists associated with them.
+;;
+(module slsets
+    (slset<= slset= slset-adjoin ;; TODO: slset-delete and slset-contains?
+     slset-difference slset-intersection
+     slset-difference+intersection
+     slset-union slset-xor
+     slset-deduplicate)
+
+(import scheme (chicken base) (chicken foreign) (chicken plist))
+
+(define-inline (mark! x marking)
+  (when (symbol? x) (put! x marking #t)))
+
+(define-inline (mark-list! lst marking)
+  (for-each (lambda (x) (mark! x marking)) lst))
+
+(define-inline (unmark! x marking)
+  (when (symbol? x) (remprop! x marking)))
+
+(define-inline (unmark-list! lst marking)
+  (for-each (lambda (x) (unmark! x marking)) lst))
+
+(define-inline (with-marked-list lst fun)
+  (let ((marking (gensym 'm)))
+    (dynamic-wind
+        (lambda () (mark-list! lst marking))
+        (lambda () (fun marking))
+        (lambda () (unmark-list! lst marking)))))
+
+(define-inline (every? pred lst)
+  (let lp ((lst lst))
+    (cond ((null? lst) #t)
+          ((not (pred (car lst))) #f)
+          (else (lp (cdr lst))))))
+
+(define-inline (marked? x marking)
+  (and (symbol? x) (get x marking)))
+
+(define (last lst)
+  (if (null? (cdr lst))
+      (car lst)
+      (last (cdr lst))))
+
+(define-inline (filter pred lst)
+  (let lp ((lst lst)
+           (res '()))
+    (cond ((null? lst) (reverse res))
+          ((not (pred (car lst))) (lp (cdr lst) res))
+          (else (lp (cdr lst) (cons (car lst) res))))))
+
+(define (slset<= . lsts)
+  (or (null? lsts)
+      (let ((last-list (last lsts)))
+       (with-marked-list last-list
+                         (lambda (m)
+                           (every? (lambda (lst)
+                                     (or (eq? lst last-list) ; Avoid filtering out this one and building a new list
+                                         (every? (lambda (x) (marked? x m)) lst)))
+                                   lsts))))))
+
+(define (slset= . lsts)
+  (or (null? lsts)
+      (let ((lst (car lsts))
+            (lsts (cdr lsts)))
+        (every? (lambda (l)
+                  (and (slset<= lst l) (slset<= l lst)))
+                lsts))))
+
+(define (slset-adjoin lst . els)
+  (with-marked-list lst
+                    (lambda (m)
+                      (let lp ((lst lst)
+                               (els els))
+                        (cond ((null? els) lst)
+                              ((marked? (car els) m) (lp lst (cdr els)))
+                              (else (mark! (car els) m)
+                                    (lp (cons (car els) lst) (cdr els))))))))
+
+(define (slset-difference lst . lsts)
+  (let lp ((lsts lsts)
+           (res lst))
+    (if (null? lsts)
+        res
+        (lp (cdr lsts)
+            (with-marked-list (car lsts) (lambda (m) (filter (lambda (x) (not (marked? x m))) res)))))))
+
+(define (slset-intersection lst . lsts)
+  (let lp ((lsts lsts)
+           (res lst))
+    (if (null? lsts)
+        res
+        (lp (cdr lsts)
+            (with-marked-list (car lsts)
+                              (lambda (m) (filter (lambda (x) (marked? x m)) res)))))))
+
+;; TODO: Make this faster
+(define (slset-difference+intersection lst . lsts)
+  (values (apply slset-difference lst lsts)
+          (apply slset-intersection lst lsts)))
+
+;; NOTE: Can't use mark-list here, so roll our own!
+;; TODO: Clean up if there's an error cdring down any of these lists?
+(define (slset-union . lsts)
+  (if (null? lsts)
+      '()
+      (let ((marking (gensym 'm))
+            (first-list (car lsts)))
+        (mark-list! first-list marking)
+        (let lp ((lsts (cdr lsts))
+                 (res first-list))
+          (if (null? lsts)
+              (begin (unmark-list! res marking)
+                     res)
+              (let lp2 ((lst (car lsts))
+                        (res res))
+                (if (null? lst)
+                    (lp (cdr lsts) res)
+                    (let ((x (car lst)))
+                      (if (marked? x marking)
+                          (lp2 (cdr lst) res)
+                          (begin (mark! x marking)
+                                 (lp2 (cdr lst) (cons x res))))))))))))
+
+(define (slset-xor . lsts)
+  (let lp ((lsts lsts)
+           (res '()))
+    (if (null? lsts)
+        res
+        (lp (cdr lsts)
+            (append (slset-difference res (car lsts))
+                    (slset-difference (car lsts) res))))))
+
+;; NOTE: Can't use mark-list here, so roll our own!
+;; TODO: Clean up if there's an error cdring down the list?
+(define (slset-deduplicate lst)
+  (let ((marking (gensym 'm)))
+    (let lp ((lst lst)
+             (res '()))
+      (if (null? lst)
+          (begin (unmark-list! res marking)
+                 (reverse res))
+          (let ((x (car lst)))
+            (cond ((marked? x marking)
+                   (lp (cdr lst) res))
+                  (else (mark! x marking)
+                        (lp (cdr lst) (cons x res)))))))))
+
+)