(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))))))