#lang scheme
(require "private/common.ss")
(provide set? list->set set->list empty empty?
         intersection difference partition union xor
         intersections differences partitions unions xors
         adjoin add contains?
         set<=? set=?
         for/set for*/set)

(define-struct set (elts)
  #:property prop:custom-write (lambda (set port write?)
                                 (write-hash "set" (set-elts set) port write?)))

(define (list->set ls)
  (make-set (for/hash ([x ls])
              (values x #t))))

(define (set->list set)
  (for/list ([(key value) (set-elts set)])
    key))

(define (intersection set . sets)
  (make-set (hash-intersection (set-elts set) (map set-elts sets) for/hash)))

(define (intersections sets)
  (make-set (hash-intersection (set-elts (car sets)) (map set-elts (cdr sets)) for/hash)))

(define (difference set . sets)
  (make-set (hash-difference (set-elts set) (map set-elts sets) for/hash)))

(define (differences sets)
  (make-set (hash-difference (set-elts (car sets)) (map set-elts (cdr sets)) for/hash)))

(define (partition set . sets)
  (let-values ([(diff intersection) ((hash-partition #hash()) (set-elts set) (map set-elts sets))])
    (values (make-set diff) (make-set intersection))))

(define (partitions sets)
  (let-values ([(diff intersection) ((hash-partition #hash()) (set-elts (car sets)) (map set-elts (cdr sets)))])
    (values (make-set diff) (make-set intersection))))

(define empty (make-set #hash()))

(define (empty? set)
  (zero? (hash-count (set-elts set))))

(define (unions sets)
  (make-set (foldr union1 #hash() (map set-elts sets))))

(define (union . sets)
  (unions sets))

(define (xor . sets)
  (xors sets))

(define (xors sets)
  (make-set (foldr (xor1 #hash()) #hash() (map set-elts sets))))

(define (adjoin set . elts)
  (union set (list->set elts)))

(define (add elt set)
  (adjoin set elt))

(define (contains? set elt)
  (hash-ref (set-elts set) elt (lambda () #f)))

(define-syntax-rule (for/set (for-clause ...) body0 body ...)
  (make-set (for/hash (for-clause ...)
              (values (let () body0 body ...) #t))))
  
(define-syntax-rule (for*/set (for-clause ...) body0 body ...)
  (make-set (for*/hash (for-clause ...)
              (values (let () body0 body ...) #t))))

(define (set<=? . sets)
  (let loop ([hashes (map set-elts sets)])
    (match hashes
      [(cons hash1 (and hashes (cons hash2 _)))
       (and (<=?1 hash1 hash2) (loop hashes))]
      [_ #t])))

(define (set=? . sets)
  (let loop ([hashes (map set-elts sets)])
    (match hashes
      [(cons hash1 (and hashes (cons hash2 _)))
       (and (=?1 hash1 hash2) (loop hashes))]
      [_ #t])))