summaryrefslogtreecommitdiff
path: root/slsets.scm
diff options
context:
space:
mode:
Diffstat (limited to 'slsets.scm')
-rw-r--r--slsets.scm225
1 files changed, 0 insertions, 225 deletions
diff --git a/slsets.scm b/slsets.scm
deleted file mode 100644
index ce8f67c..0000000
--- a/slsets.scm
+++ /dev/null
@@ -1,225 +0,0 @@
-;;
-;; 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.
-;;
-(declare (disable-interrupts))
-
-(module slsets
- (slset<= slset= slset-adjoin
- slset-difference slset-intersection
- slset-difference+intersection
- slset-union slset-xor
- slset-deduplicate
- slset-delete slset-contains?
-
- with-reified-slset reified-slset? reified-slset->slset
- reified-slset-adjoin! reified-slset-delete! reified-slset-contains?)
-
-(import scheme (chicken base) (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)
- (dynamic-wind
- void
- (lambda ()
- (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))))))
- (lambda ()
- (unmark-list! els m))))))
-
-(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)))))))))
-
-;; These are not really necessary - one can use memq and srfi-1's delete.
-;; But they're supplied so we have the full gamut of set operations.
-;; Also, deletion is a bit more ergonomic as it accepts multiple arguments.
-(define (slset-contains? slset el)
- (and (memq el slset) #t))
-
-(define (slset-delete slset . els)
- (with-marked-list els
- (lambda (m)
- (filter (lambda (x) (not (marked? x m))) slset))))
-
-(define-record-type :reified-slset
- (reified-slset marking slset)
- reified-slset?
- (marking reified-slset-marking)
- (slset reified-slset-list reified-slset-list-set!))
-
-(define reified-slset->slset reified-slset-list)
-
-(define (with-reified-slset lst fun)
- ;; Note: we can't use with-marked-list here because the reified
- ;; slset will be mutated in-place, so the enter/leave thunks must
- ;; extract the *current* list from the reified slset every time.
- (let* ((marking (gensym 'm))
- (rs (reified-slset marking lst)))
- (dynamic-wind
- (lambda () (mark-list! (reified-slset-list rs) marking))
- (lambda ()
- (receive res (fun rs)
- (apply values (reified-slset-list rs) res)))
- (lambda () (unmark-list! (reified-slset-list rs) marking)))))
-
-(define (reified-slset-adjoin! rs . els)
- (let ((m (reified-slset-marking rs)))
- (let lp ((lst (reified-slset-list rs))
- (els els))
- (cond ((null? els)
- (reified-slset-list-set! rs lst)
- rs)
- ((marked? (car els) m) (lp lst (cdr els)))
- (else (mark! (car els) m)
- (lp (cons (car els) lst) (cdr els)))))))
-
-;; NOTE: Deleting elements not already occurring in the list is O(1)
-(define (reified-slset-delete! rs . els)
- (let* ((m1 (reified-slset-marking rs))
- (els (filter (lambda (e) (not (marked? m1 e))) els)))
- (unless (null? els)
- (let ((lst (with-marked-list els
- (lambda (m2)
- (filter (lambda (el) (not (marked? el m2)))
- (reified-slset-list rs))))))
- (for-each (lambda (e) (unmark! e m1)) els)
- (reified-slset-list-set! rs lst)))
- rs))
-
-(define (reified-slset-contains? rs el)
- (marked? el (reified-slset-marking rs)))
-
-)
generated by cgit v1.2.3 (git 2.39.1) at 2025-08-23 16:20:51 +0000