(module table-from-set mzscheme
(require "../private/require.ss")
(require-contracts)
(require-etc)
(require-lists)
(require-class)
(require "table-interface.ss"
"../iterator/iterator-interface.ss"
"../set/set-interface.ss"
"../set/unordered-set.ss"
"../private/method.ss"
"../private/binding.ss")
(provide/contract
[table-from-set% (implementation?/c table<%>)]
[make-table-from-set ((set-of/c binding?) . -> . table/c)])
(define (make-table-from-set set)
(new table-from-set% [set set]))
(define-syntax (define/table stx)
(syntax-case stx ()
[(_ . REST) #'(define/export public table- . REST)]))
(define table-from-set%
(class* object% (table<%>)
(super-new)
(init-field set)
(define/private (copy/set new-set)
(new table-from-set% [set new-set]))
(define/table (sexp)
(map binding->sexp (send set elements)))
(define/table (alist)
(map (lambda (bind) (cons (binding-key bind) (binding-value bind)))
(send set elements)))
(define/table (keys)
(map binding-key (send set elements)))
(define/table (values)
(map binding-value (send set elements)))
(define/table (insert key value)
(copy/set (send set insert (make-binding key value))))
(define/table lookup
(opt-lambda (key [failure (constant #f)] [success identity])
(send set lookup (make-binding key null)
failure
(compose success binding-value))))
(define/table lookup/key
(opt-lambda (key [failure (constant #f)] [success (lambda (k v) k)])
(send set lookup (make-binding key null)
failure
(lambda (binding)
(success (binding-key binding) (binding-value binding))))))
(define/table (update key transform)
(table-lookup/key key
(lambda () this)
(lambda (k v)
(table-insert k (transform k v)))))
(define/table (update/value key transform)
(table-update key (lambda (k v) (transform v))))
(define/table (update/insert key transform value)
(table-lookup/key key
(lambda () (table-insert key value))
(lambda (k v)
(table-insert k (transform k v)))))
(define/table (update/insert/value key transform value)
(table-update/insert key (lambda (k v) (transform v)) value))
(define/table (iterator)
(new binding-iterator% [set-iter (send set iterator)]))
(define/table (remove key)
(copy/set (send set remove (make-binding key 'placeholder))))
(define/table (select)
(let* ([binding (send set select)])
(values (binding-key binding)
(binding-value binding))))
(define/table (select/key)
(let*-values ([(key value) (table-select)])
key))
(define/table (select/value)
(let*-values ([(key value) (table-select)])
value))
(define/table (empty?)
(send set empty?))
(define/table (clear)
(copy/set (send set clear)))
(define/table (size)
(send set size))
(define/table (contains? key)
(table-lookup key (lambda () #f) (lambda (any) #t)))
(define/table (fold combine init)
(send set fold
(lambda (binding result)
(combine (binding-key binding)
(binding-value binding)
result))
init))
(define/table (fold/key combine init)
(table-fold (lambda (key value result) (combine key result)) init))
(define/table (fold/value combine init)
(table-fold (lambda (key value result) (combine value result)) init))
(define/table (map transform)
(table-fold (lambda (key value table)
(send table insert key (transform key value)))
(table-clear)))
(define/table (map/key transform)
(table-map (lambda (key value) (transform key))))
(define/table (map/value transform)
(table-map (lambda (key value) (transform value))))
(define/table (filter predicate)
(copy/set (send set filter
(lambda (binding)
(predicate (binding-key binding)
(binding-value binding))))))
(define/table (filter/key predicate)
(table-filter (lambda (key value) (predicate key))))
(define/table (filter/value predicate)
(table-filter (lambda (key value) (predicate value))))
(define/table (for-each action)
(send set for-each
(lambda (binding)
(action (binding-key binding)
(binding-value binding)))))
(define/table (for-each/key action)
(table-for-each (lambda (key value) (action key))))
(define/table (for-each/value action)
(table-for-each (lambda (key value) (action value))))
(define/table (all? predicate)
(send set all?
(lambda (binding)
(predicate (binding-key binding)
(binding-value binding)))))
(define/table (all?/key predicate)
(table-all? (lambda (key value) (predicate key))))
(define/table (all?/value predicate)
(table-all? (lambda (key value) (predicate value))))
(define/table (any? predicate)
(send set any?
(lambda (binding)
(predicate (binding-key binding)
(binding-value binding)))))
(define/table (any?/key predicate)
(table-any? (lambda (key value) (predicate key))))
(define/table (any?/value predicate)
(table-any? (lambda (key value) (predicate value))))
(define/table union
(opt-lambda (other [combine (lambda (key one two) one)])
(send other fold
(lambda (key value set)
(if (table-contains? key)
(send set insert key
(combine key (table-lookup key) value))
(send set insert key value)))
this)))
(define/table union/value
(opt-lambda (other [combine (lambda (one two) one)])
(table-union other (lambda (key one two) (combine one two)))))
(define/table intersection
(opt-lambda (other [combine (lambda (key one two) one)])
(send other fold
(lambda (key value set)
(if (table-contains? key)
(send set insert key
(combine key (table-lookup key) value))
set))
(table-clear))))
(define/table intersection/value
(opt-lambda (other [combine (lambda (one two) one)])
(table-intersection other (lambda (key one two) (combine one two)))))
(define/table (difference other)
(table-filter/key (lambda (key) (not (send other contains? key)))))
(define/table (subtable? value=? other)
(table-all? (lambda (key value1)
(send other lookup key
(lambda () #f)
(lambda (value2) (value=? value1 value2))))))
(define/table (equal? value=? other)
(and (send other all?/key (lambda (key) (table-contains? key)))
(table-subtable? value=? other)))
))
(define binding-iterator%
(class* object% (indexed-iterator<%>)
(super-new)
(init-field set-iter)
(define/private (copy/iter iter)
(new binding-iterator% [set-iter iter]))
(define/public (end?)
(send set-iter end?))
(define/public (next)
(copy/iter (send set-iter next)))
(define/public (key)
(binding-key (send set-iter element)))
(define/public (element)
(binding-value (send set-iter element)))
))
)