diff options
Diffstat (limited to 'slset.scm')
| -rw-r--r-- | slset.scm | 225 |
1 files changed, 225 insertions, 0 deletions
diff --git a/slset.scm b/slset.scm new file mode 100644 index 0000000..8221089 --- /dev/null +++ b/slset.scm @@ -0,0 +1,225 @@ +;; +;; 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 slset + (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))) + +) |