Added gen:set, mutable and weak sets, and custom set types.
Sets are now implemented as a generic interface, and lists count as sets. Most of the set functions have been added as methods, including mutable versions of imperative update methods.
This commit is contained in:
Carl Eastlund
parent
da1fe888a7
commit
a651591a15
849
racket/collects/racket/private/set-types.rkt
Normal file
849
racket/collects/racket/private/set-types.rkt
Normal file
|
|
@ -0,0 +1,849 @@
|
|||
#lang racket/base
|
||||
(require racket/private/set
|
||||
racket/stream
|
||||
racket/serialize
|
||||
racket/pretty
|
||||
racket/sequence
|
||||
(only-in racket/syntax format-symbol)
|
||||
(for-syntax racket/base racket/syntax))
|
||||
|
||||
(provide set seteq seteqv
|
||||
weak-set weak-seteq weak-seteqv
|
||||
mutable-set mutable-seteq mutable-seteqv
|
||||
list->set list->seteq list->seteqv
|
||||
list->weak-set list->weak-seteq list->weak-seteqv
|
||||
list->mutable-set list->mutable-seteq list->mutable-seteqv
|
||||
set-eq? set-eqv? set-equal?
|
||||
set-weak? set-mutable? set-immutable?
|
||||
for/set for/seteq for/seteqv
|
||||
for*/set for*/seteq for*/seteqv
|
||||
for/weak-set for/weak-seteq for/weak-seteqv
|
||||
for*/weak-set for*/weak-seteq for*/weak-seteqv
|
||||
for/mutable-set for/mutable-seteq for/mutable-seteqv
|
||||
for*/mutable-set for*/mutable-seteq for*/mutable-seteqv
|
||||
|
||||
define-custom-set-types
|
||||
make-custom-set-types
|
||||
make-custom-set
|
||||
make-weak-custom-set
|
||||
make-mutable-custom-set)
|
||||
|
||||
(define (custom-set-empty? s)
|
||||
(dprintf "custom-set-empty?\n")
|
||||
(hash-empty? (custom-set-table s)))
|
||||
|
||||
(define (custom-set-member? s x)
|
||||
(dprintf "custom-set-member?\n")
|
||||
(set-check-elem 'set-member? s x)
|
||||
(hash-ref (custom-set-table s)
|
||||
(set-wrap-elem s x)
|
||||
#f))
|
||||
|
||||
(define (custom-set-count s)
|
||||
(dprintf "custom-set-count\n")
|
||||
(hash-count (custom-set-table s)))
|
||||
|
||||
(define (custom-set=? s1 s2)
|
||||
(dprintf "custom-set=?\n")
|
||||
(unless (set? s2)
|
||||
(raise-argument-error 'set=? "set?" 1 s1 s2))
|
||||
(set-check-compatible 'set=? s1 s2)
|
||||
(define table1 (custom-set-table s1))
|
||||
(define table2 (custom-set-table s2))
|
||||
(and (for/and ([k (in-hash-keys table1)])
|
||||
(hash-ref table2 k #f))
|
||||
(for/and ([k (in-hash-keys table2)])
|
||||
(hash-ref table1 k #f))))
|
||||
|
||||
(define (custom-subset? s1 s2)
|
||||
(dprintf "custom-subset?\n")
|
||||
(unless (set? s2)
|
||||
(raise-argument-error 'subset? "set?" 1 s1 s2))
|
||||
(set-check-compatible 'subset? s1 s2)
|
||||
(define table1 (custom-set-table s1))
|
||||
(define table2 (custom-set-table s2))
|
||||
(for/and ([k (in-hash-keys table1)])
|
||||
(hash-ref table2 k #f)))
|
||||
|
||||
(define (custom-proper-subset? s1 s2)
|
||||
(dprintf "custom-proper-subset?\n")
|
||||
(unless (set? s2)
|
||||
(raise-argument-error 'proper-subset? "set?" 1 s1 s2))
|
||||
(set-check-compatible 'proper-subset? s1 s2)
|
||||
(define table1 (custom-set-table s1))
|
||||
(define table2 (custom-set-table s2))
|
||||
(and (for/and ([k (in-hash-keys table1)])
|
||||
(hash-ref table2 k #f))
|
||||
(for/or ([k (in-hash-keys table2)])
|
||||
(not (hash-ref table1 k #f)))))
|
||||
|
||||
(define (custom-set-map s f)
|
||||
(dprintf "custom-set-map\n")
|
||||
(for/fold ([xs '()]) ([k (in-hash-keys (custom-set-table s))])
|
||||
(cons (f (set-unwrap-key s k)) xs)))
|
||||
|
||||
(define (custom-set-for-each s f)
|
||||
(dprintf "custom-set-for-each\n")
|
||||
(for ([k (in-hash-keys (custom-set-table s))])
|
||||
(f (set-unwrap-key s k))))
|
||||
|
||||
(define (custom-set-copy s)
|
||||
(dprintf "custom-set-copy\n")
|
||||
(update-custom-set-table s (hash-copy (custom-set-table s))))
|
||||
|
||||
(define (custom-set->list s)
|
||||
(dprintf "custom-set->list\n")
|
||||
(for/fold ([xs '()]) ([k (in-hash-keys (custom-set-table s))])
|
||||
(cons (set-unwrap-key s k) xs)))
|
||||
|
||||
(define (custom-set->stream s)
|
||||
(dprintf "custom-set->stream\n")
|
||||
(sequence->stream (custom-in-set s)))
|
||||
|
||||
(define (custom-set-first s)
|
||||
(dprintf "custom-set-first\n")
|
||||
(define table (custom-set-table s))
|
||||
(define i (hash-iterate-first table))
|
||||
(unless i
|
||||
(raise-argument-error 'set-first "(and/c set? (not/c set-empty?))" s))
|
||||
(set-unwrap-key s (hash-iterate-key table i)))
|
||||
|
||||
(define (custom-set-rest s)
|
||||
(dprintf "custom-set-rest\n")
|
||||
(define table (custom-set-table s))
|
||||
(define i (hash-iterate-first table))
|
||||
(unless i
|
||||
(raise-argument-error 'set-rest "(and/c set? (not/c set-empty?))" s))
|
||||
(update-custom-set-table s (hash-remove table (hash-iterate-key table i))))
|
||||
|
||||
(define (custom-set-add s x)
|
||||
(dprintf "custom-set-add\n")
|
||||
(set-check-elem 'set-add s x)
|
||||
(update-custom-set-table
|
||||
s
|
||||
(hash-set (custom-set-table s) (set-wrap-elem s x) #t)))
|
||||
|
||||
(define (custom-set-remove s x)
|
||||
(dprintf "custom-set-remove\n")
|
||||
(set-check-elem 'set-remove s x)
|
||||
(update-custom-set-table
|
||||
s
|
||||
(hash-remove (custom-set-table s) (set-wrap-elem s x))))
|
||||
|
||||
(define (custom-set-clear s)
|
||||
(dprintf "custom-set-clear\n")
|
||||
(update-custom-set-table s (hash-clear (custom-set-table s))))
|
||||
|
||||
(define (choose-immutable who better? set0 sets)
|
||||
(for/fold ([largest set0]) ([s (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s)
|
||||
(apply raise-argument-error who "set?" i set0 sets))
|
||||
(set-check-compatible who set0 s)
|
||||
(if (and (immutable? (custom-set-table s))
|
||||
(better? (hash-count (custom-set-table s))
|
||||
(hash-count (custom-set-table largest))))
|
||||
s
|
||||
largest)))
|
||||
|
||||
(define (choose-largest-immutable who set0 sets)
|
||||
(choose-immutable who > set0 sets))
|
||||
|
||||
(define (choose-smallest-immutable who set0 sets)
|
||||
(choose-immutable who < set0 sets))
|
||||
|
||||
(define (custom-set-union s . sets)
|
||||
(dprintf "custom-set-union\n")
|
||||
(define largest-immutable
|
||||
(choose-largest-immutable 'set-union s sets))
|
||||
(update-custom-set-table
|
||||
s
|
||||
(for/fold
|
||||
([table (custom-set-table largest-immutable)])
|
||||
([s2 (in-list (cons s sets))]
|
||||
#:unless (eq? s2 largest-immutable))
|
||||
(for/fold ([table table]) ([x (in-hash-keys (custom-set-table s2))])
|
||||
(hash-set table x #t)))))
|
||||
|
||||
(define (custom-set-symmetric-difference s . sets)
|
||||
(dprintf "custom-set-symmetric-difference\n")
|
||||
(define largest-immutable
|
||||
(choose-largest-immutable 'set-symmetric-difference s sets))
|
||||
(update-custom-set-table
|
||||
s
|
||||
(for/fold
|
||||
([table (custom-set-table largest-immutable)])
|
||||
([s2 (in-list (cons s sets))]
|
||||
#:unless (eq? s2 largest-immutable))
|
||||
(for/fold ([table table]) ([x (in-hash-keys (custom-set-table s2))])
|
||||
(if (hash-ref table x #f)
|
||||
(hash-remove table x)
|
||||
(hash-set table x #t))))))
|
||||
|
||||
(define (custom-set-intersect s . sets)
|
||||
(dprintf "custom-set-intersect\n")
|
||||
(define smallest-immutable
|
||||
(choose-smallest-immutable 'set-intersect s sets))
|
||||
(define all-sets (cons s sets))
|
||||
(define (keep? k)
|
||||
(for/and ([s2 (in-list all-sets)]
|
||||
#:unless (eq? s2 smallest-immutable))
|
||||
(hash-ref (custom-set-table s2) k #f)))
|
||||
(define smallest-table (custom-set-table smallest-immutable))
|
||||
(update-custom-set-table
|
||||
s
|
||||
(for/fold
|
||||
([table smallest-table])
|
||||
([k (in-hash-keys smallest-table)]
|
||||
#:unless (keep? k))
|
||||
(hash-remove table k))))
|
||||
|
||||
(define (custom-set-subtract s . sets)
|
||||
(dprintf "custom-set-subtract\n")
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-subtract "set?" i s sets))
|
||||
(set-check-compatible 'set-subtract s s2))
|
||||
(define (remove? k)
|
||||
(for/or ([s2 (in-list sets)])
|
||||
(hash-ref (custom-set-table s2) k #f)))
|
||||
(define initial-table (custom-set-table s))
|
||||
(update-custom-set-table
|
||||
s
|
||||
(for/fold
|
||||
([table initial-table])
|
||||
([k (in-hash-keys initial-table)]
|
||||
#:when (remove? k))
|
||||
(hash-remove table k))))
|
||||
|
||||
(define (custom-set-add! s x)
|
||||
(dprintf "custom-set-add!\n")
|
||||
(set-check-elem 'set-add! s x)
|
||||
(hash-set! (custom-set-table s) (set-wrap-elem s x) #t))
|
||||
|
||||
(define (custom-set-remove! s x)
|
||||
(dprintf "custom-set-remove!\n")
|
||||
(set-check-elem 'set-remove! s x)
|
||||
(hash-remove! (custom-set-table s) (set-wrap-elem s x)))
|
||||
|
||||
(define (custom-set-clear! s)
|
||||
(dprintf "custom-set-clear!\n")
|
||||
(hash-clear! (custom-set-table s)))
|
||||
|
||||
(define (custom-set-union! s . sets)
|
||||
(dprintf "custom-set-union!\n")
|
||||
(define table (custom-set-table s))
|
||||
(for ([s2 (in-list sets)]
|
||||
[i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-union! "set?" i s sets))
|
||||
(set-check-compatible 'set-union! s s2)
|
||||
(for ([x (in-hash-keys (custom-set-table s2))])
|
||||
(hash-set! table x #t))))
|
||||
|
||||
(define (custom-set-symmetric-difference! s . sets)
|
||||
(dprintf "custom-set-symmetric-difference!\n")
|
||||
(define table (custom-set-table s))
|
||||
(for ([s2 (in-list sets)]
|
||||
[i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-symmetric-difference! "set?" i s sets))
|
||||
(set-check-compatible 'set-symmetric-difference! s s2)
|
||||
(for ([x (in-hash-keys (custom-set-table s2))])
|
||||
(if (hash-ref table x #f)
|
||||
(hash-remove! table x)
|
||||
(hash-set! table x #t)))))
|
||||
|
||||
(define (custom-set-intersect! s . sets)
|
||||
(dprintf "custom-set-intersect!\n")
|
||||
(define tables
|
||||
(for/list ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-intersect! "set?" i s sets))
|
||||
(set-check-compatible 'set-intersect! s s2)
|
||||
(custom-set-table s2)))
|
||||
(define (keep? k)
|
||||
(for/and ([table (in-list tables)])
|
||||
(hash-ref table k #f)))
|
||||
(define table (custom-set-table s))
|
||||
(define to-remove
|
||||
(for/list ([k (in-hash-keys table)]
|
||||
#:unless (keep? k))
|
||||
k))
|
||||
(for ([k (in-list to-remove)])
|
||||
(hash-remove! table k)))
|
||||
|
||||
(define (custom-set-subtract! s . sets)
|
||||
(dprintf "custom-set-subtract!\n")
|
||||
(define tables
|
||||
(for/list ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-subtract! "set?" i s sets))
|
||||
(set-check-compatible 'set-subtract! s s2)
|
||||
(custom-set-table s2)))
|
||||
(define (remove? k)
|
||||
(for/or ([table (in-list tables)])
|
||||
(hash-ref table k #f)))
|
||||
(define table (custom-set-table s))
|
||||
(define to-remove
|
||||
(for/list ([k (in-hash-keys table)]
|
||||
#:when (remove? k))
|
||||
k))
|
||||
(for ([k (in-list to-remove)])
|
||||
(hash-remove! table k)))
|
||||
|
||||
(define (set-wrap-elem d x)
|
||||
(define spec (custom-set-spec d))
|
||||
(wrap-elem spec x))
|
||||
|
||||
(define (wrap-elem spec x)
|
||||
(cond
|
||||
[spec
|
||||
(define wrap (custom-spec-wrap spec))
|
||||
(define intern (custom-spec-intern spec))
|
||||
(ephemeron-value
|
||||
(hash-ref! intern x
|
||||
(lambda ()
|
||||
(make-ephemeron x (wrap x)))))]
|
||||
[else x]))
|
||||
|
||||
(define (set-unwrap-key d k)
|
||||
(define spec (custom-set-spec d))
|
||||
(unwrap-key spec k))
|
||||
|
||||
(define (unwrap-key spec k)
|
||||
(if spec (custom-elem-contents k) k))
|
||||
|
||||
(define (set-check-elem who d x)
|
||||
(define spec (custom-set-spec d))
|
||||
(check-elem who spec x))
|
||||
|
||||
(define (check-elem who spec x)
|
||||
(when spec
|
||||
(define elem? (custom-spec-elem? spec))
|
||||
(unless (elem? x)
|
||||
(raise-argument-error who (format "~a" elem?) x))))
|
||||
|
||||
(define (update-custom-set-table s table)
|
||||
(cond
|
||||
[(immutable? table) (immutable-custom-set (custom-set-spec s) table)]
|
||||
[(hash-weak? table) (weak-custom-set (custom-set-spec s) table)]
|
||||
[else (mutable-custom-set (custom-set-spec s) table)]))
|
||||
|
||||
(define (set-check-compatible name s1 s2)
|
||||
(define spec (custom-set-spec s1))
|
||||
(unless (and (custom-set? s2)
|
||||
(eq? (custom-set-spec s2) spec)
|
||||
(or spec
|
||||
(hash-compatible? (custom-set-table s1)
|
||||
(custom-set-table s2))))
|
||||
(raise-arguments-error
|
||||
name
|
||||
"set arguments have incompatible equivalence predicates"
|
||||
"first set" s1
|
||||
"incompatible set" s2)))
|
||||
|
||||
(define (hash-compatible? x y)
|
||||
(cond
|
||||
[(hash-equal? x) (hash-equal? y)]
|
||||
[(hash-eqv? x) (hash-eqv? y)]
|
||||
[(hash-eq? x) (hash-eq? y)]))
|
||||
|
||||
(define (write-custom-set s port mode)
|
||||
|
||||
(define table (custom-set-table s))
|
||||
(define key-str
|
||||
(cond
|
||||
[(immutable? table) ""]
|
||||
[(hash-weak? table) "weak-"]
|
||||
[else "mutable-"]))
|
||||
|
||||
(cond
|
||||
[(custom-set-spec s) (fprintf port "#<~acustom-set>" key-str)]
|
||||
[else
|
||||
|
||||
(define show
|
||||
(case mode
|
||||
[(#t) write]
|
||||
[(#f) display]
|
||||
[else (lambda (p port) (print p port mode))]))
|
||||
|
||||
(define-values (left-str mid-str right-str)
|
||||
(case mode
|
||||
[(0) (values "(" "" ")")]
|
||||
[else (values "#<" ":" ">")]))
|
||||
(define cmp-str
|
||||
(cond
|
||||
[(hash-equal? table) "set"]
|
||||
[(hash-eqv? table) "seteqv"]
|
||||
[(hash-eq? table) "seteq"]))
|
||||
|
||||
(define (show-prefix port)
|
||||
(write-string left-str port)
|
||||
(write-string key-str port)
|
||||
(write-string cmp-str port)
|
||||
(write-string mid-str port))
|
||||
|
||||
(define (show-suffix port)
|
||||
(write-string right-str port))
|
||||
|
||||
(define (show-one-line port)
|
||||
(show-prefix port)
|
||||
(for ([k (in-hash-keys table)])
|
||||
(write-string " " port)
|
||||
(show k port))
|
||||
(show-suffix port))
|
||||
|
||||
(define (show-multi-line port)
|
||||
(define-values (line col pos) (port-next-location port))
|
||||
(show-prefix port)
|
||||
(for ([k (in-hash-keys table)])
|
||||
(pretty-print-newline port (pretty-print-columns))
|
||||
(for ([i (in-range (add1 col))])
|
||||
(write-char #\space port))
|
||||
(show k port))
|
||||
(show-suffix port))
|
||||
|
||||
(cond
|
||||
[(and (pretty-printing)
|
||||
(integer? (pretty-print-columns)))
|
||||
(define proc
|
||||
(let/ec return
|
||||
(define pretty-port
|
||||
(make-tentative-pretty-print-output-port
|
||||
port
|
||||
(- (pretty-print-columns) 1)
|
||||
(lambda ()
|
||||
(return
|
||||
(lambda ()
|
||||
(tentative-pretty-print-port-cancel pretty-port)
|
||||
(show-multi-line port))))))
|
||||
(show-one-line port)
|
||||
(tentative-pretty-print-port-transfer pretty-port port)
|
||||
void))
|
||||
(proc)]
|
||||
[else (show-one-line port)])]))
|
||||
|
||||
(define (custom-in-set s)
|
||||
(define keys (in-hash-keys (custom-set-table s)))
|
||||
(if (custom-set-spec s)
|
||||
(sequence-map custom-elem-contents keys)
|
||||
keys))
|
||||
|
||||
(struct custom-elem [contents])
|
||||
|
||||
(struct custom-spec [elem? wrap intern])
|
||||
|
||||
(serializable-struct custom-set [spec table]
|
||||
#:property prop:sequence custom-in-set
|
||||
#:property prop:custom-print-quotable 'never
|
||||
#:methods gen:custom-write
|
||||
[(define write-proc write-custom-set)]
|
||||
#:methods gen:equal+hash
|
||||
[(define (equal-proc x y rec)
|
||||
(and (eq? (custom-set-spec x)
|
||||
(custom-set-spec y))
|
||||
(rec (custom-set-table x)
|
||||
(custom-set-table y))))
|
||||
(define (hash-proc x rec)
|
||||
(+ (eq-hash-code (custom-set-spec x))
|
||||
(rec (custom-set-table x))
|
||||
custom-set-constant))
|
||||
(define (hash2-proc x rec)
|
||||
(rec (custom-set-table x)))])
|
||||
|
||||
(define custom-set-constant
|
||||
(equal-hash-code "hash code for a set based on a hash table"))
|
||||
|
||||
(serializable-struct immutable-custom-set custom-set []
|
||||
#:methods gen:stream
|
||||
[(define stream-empty? custom-set-empty?)
|
||||
(define stream-first custom-set-first)
|
||||
(define stream-rest custom-set-rest)]
|
||||
#:methods gen:set
|
||||
[(define set-empty? custom-set-empty?)
|
||||
(define set-member? custom-set-member?)
|
||||
(define set-count custom-set-count)
|
||||
(define set=? custom-set=?)
|
||||
(define subset? custom-subset?)
|
||||
(define proper-subset? custom-proper-subset?)
|
||||
(define set-map custom-set-map)
|
||||
(define set-for-each custom-set-for-each)
|
||||
(define set-copy custom-set-copy)
|
||||
(define set->list custom-set->list)
|
||||
(define set->stream custom-set->stream)
|
||||
(define in-set custom-in-set)
|
||||
(define set-first custom-set-first)
|
||||
(define set-rest custom-set-rest)
|
||||
(define set-add custom-set-add)
|
||||
(define set-remove custom-set-remove)
|
||||
(define set-clear custom-set-clear)
|
||||
(define set-union custom-set-union)
|
||||
(define set-intersect custom-set-intersect)
|
||||
(define set-subtract custom-set-subtract)
|
||||
(define set-symmetric-difference custom-set-symmetric-difference)])
|
||||
|
||||
(serializable-struct imperative-custom-set custom-set []
|
||||
#:methods gen:set
|
||||
[(define set-empty? custom-set-empty?)
|
||||
(define set-member? custom-set-member?)
|
||||
(define set-count custom-set-count)
|
||||
(define set=? custom-set=?)
|
||||
(define subset? custom-subset?)
|
||||
(define proper-subset? custom-proper-subset?)
|
||||
(define set-map custom-set-map)
|
||||
(define set-for-each custom-set-for-each)
|
||||
(define set-copy custom-set-copy)
|
||||
(define set->list custom-set->list)
|
||||
(define set->stream custom-set->stream)
|
||||
(define in-set custom-in-set)
|
||||
(define set-first custom-set-first)
|
||||
(define set-clear custom-set-clear)
|
||||
(define set-add! custom-set-add!)
|
||||
(define set-remove! custom-set-remove!)
|
||||
(define set-clear! custom-set-clear!)
|
||||
(define set-union! custom-set-union!)
|
||||
(define set-intersect! custom-set-intersect!)
|
||||
(define set-subtract! custom-set-subtract!)
|
||||
(define set-symmetric-difference! custom-set-symmetric-difference!)])
|
||||
|
||||
(serializable-struct weak-custom-set imperative-custom-set [])
|
||||
|
||||
(serializable-struct mutable-custom-set imperative-custom-set [])
|
||||
|
||||
(define-syntax (define-custom-set-types stx)
|
||||
(parameterize ([current-syntax-context stx])
|
||||
(define-values (base-id args-stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name #:elem? elem? =? hc1 hc2)
|
||||
(values #'name #'(#:elem? elem? =? hc1 hc2))]
|
||||
[(_ name #:elem? elem? =? hc1)
|
||||
(values #'name #'(#:elem? elem? =? hc1))]
|
||||
[(_ name #:elem? elem? =?)
|
||||
(values #'name #'(#:elem? elem? =?))]
|
||||
[(_ name =? hc1 hc2)
|
||||
(values #'name #'(=? hc1 hc2))]
|
||||
[(_ name =? hc1)
|
||||
(values #'name #'(=? hc1))]
|
||||
[(_ name =?)
|
||||
(values #'name #'(=?))]))
|
||||
(unless (identifier? base-id)
|
||||
(wrong-syntax base-id "expected an identifier"))
|
||||
(define (id fmt) (format-id base-id fmt base-id))
|
||||
(define/with-syntax name (id "~a"))
|
||||
(define/with-syntax name? (id "~a?"))
|
||||
(define/with-syntax weak-name? (id "weak-~a?"))
|
||||
(define/with-syntax mutable-name? (id "mutable-~a?"))
|
||||
(define/with-syntax immutable-name? (id "immutable-~a?"))
|
||||
(define/with-syntax make-weak-name (id "make-weak-~a"))
|
||||
(define/with-syntax make-mutable-name (id "make-mutable-~a"))
|
||||
(define/with-syntax make-immutable-name (id "make-immutable-~a"))
|
||||
(define/with-syntax args args-stx)
|
||||
#'(define-values (name?
|
||||
weak-name?
|
||||
mutable-name?
|
||||
immutable-name?
|
||||
make-weak-name
|
||||
make-mutable-name
|
||||
make-immutable-name)
|
||||
(make-custom-set-types #:for 'define-custom-set-types
|
||||
#:name 'name
|
||||
. args))))
|
||||
|
||||
(define (make-custom-set-types =? [hc1 default-hc] [hc2 default-hc]
|
||||
#:elem? [elem? default-pred]
|
||||
#:for [who 'make-custom-set-types]
|
||||
#:name [name 'custom-set])
|
||||
(define spec (make-custom-spec who elem? =? hc1 hc2))
|
||||
(define (sym fmt) (format-symbol fmt name))
|
||||
(values (custom-set-predicate spec (sym "~a?"))
|
||||
(weak-custom-set-predicate spec (sym "weak-~a?"))
|
||||
(mutable-custom-set-predicate spec (sym "mutable-~a?"))
|
||||
(immutable-custom-set-predicate spec (sym "immutable-~a?"))
|
||||
(weak-custom-set-maker spec (sym "make-weak-~a"))
|
||||
(mutable-custom-set-maker spec (sym "make-mutable-~a"))
|
||||
(immutable-custom-set-maker spec (sym "make-immutable-~a"))))
|
||||
|
||||
(define (make-mutable-custom-set =? [hc1 default-hc] [hc2 default-hc]
|
||||
#:elem? [elem? default-pred])
|
||||
(define spec (make-custom-spec 'make-custom-set elem? =? hc1 hc2))
|
||||
(define make (mutable-custom-set-maker spec 'make))
|
||||
(make))
|
||||
|
||||
(define (make-weak-custom-set =? [hc1 default-hc] [hc2 default-hc]
|
||||
#:elem? [elem? default-pred])
|
||||
(define spec (make-custom-spec 'make-custom-set elem? =? hc1 hc2))
|
||||
(define make (weak-custom-set-maker spec 'make))
|
||||
(make))
|
||||
|
||||
(define (make-custom-set =? [hc1 default-hc] [hc2 default-hc]
|
||||
#:elem? [elem? default-pred])
|
||||
(define spec (make-custom-spec 'make-custom-set elem? =? hc1 hc2))
|
||||
(define make (immutable-custom-set-maker spec 'make))
|
||||
(make))
|
||||
|
||||
(define (make-custom-spec who elem? =? hc1 hc2)
|
||||
(check-arities who =? 2 3)
|
||||
(check-arities who hc1 1 2)
|
||||
(check-arities who hc2 1 2)
|
||||
(check-arity who elem? 1)
|
||||
(struct wrapped-elem custom-elem []
|
||||
#:methods gen:equal+hash
|
||||
[(define equal-proc
|
||||
(if (procedure-arity-includes? =? 2)
|
||||
(lambda (a b f)
|
||||
(=? (custom-elem-contents a)
|
||||
(custom-elem-contents b)))
|
||||
(lambda (a b f)
|
||||
(=? (custom-elem-contents a)
|
||||
(custom-elem-contents b)
|
||||
f))))
|
||||
(define hash-proc
|
||||
(if (procedure-arity-includes? hc1 1)
|
||||
(lambda (a f)
|
||||
(hc1 (custom-elem-contents a)))
|
||||
(lambda (a f)
|
||||
(hc1 (custom-elem-contents a) f))))
|
||||
(define hash2-proc
|
||||
(if (procedure-arity-includes? hc2 1)
|
||||
(lambda (a f)
|
||||
(hc2 (custom-elem-contents a)))
|
||||
(lambda (a f)
|
||||
(hc2 (custom-elem-contents a) f))))])
|
||||
(custom-spec elem? wrapped-elem (make-weak-hasheq)))
|
||||
|
||||
(define (default-hc x f) 1)
|
||||
(define (default-pred x) #t)
|
||||
|
||||
(define (check-arities who f a b)
|
||||
(unless (and (procedure? f)
|
||||
(or (procedure-arity-includes? f a)
|
||||
(procedure-arity-includes? f b)))
|
||||
(raise-argument-error who (arities-string a b) f)))
|
||||
|
||||
(define (check-arity who f a)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f a))
|
||||
(raise-argument-error who (arity-string a) f)))
|
||||
|
||||
(define (arities-string a b)
|
||||
(format "(or/c ~a ~a)" (arity-string a) (arity-string b)))
|
||||
|
||||
(define (arity-string a)
|
||||
(format "(procedure-arity-includes/c ~a)" a))
|
||||
|
||||
(define (custom-set-predicate spec name)
|
||||
(define (proc x)
|
||||
(dprintf "~a\n" name)
|
||||
(and (custom-set? x)
|
||||
(eq? (custom-set-spec x) spec)))
|
||||
(procedure-rename proc name))
|
||||
|
||||
(define (weak-custom-set-predicate spec name)
|
||||
(define (proc x)
|
||||
(dprintf "~a\n" name)
|
||||
(and (weak-custom-set? x)
|
||||
(eq? (custom-set-spec x) spec)))
|
||||
(procedure-rename proc name))
|
||||
|
||||
(define (mutable-custom-set-predicate spec name)
|
||||
(define (proc x)
|
||||
(dprintf "~a\n" name)
|
||||
(and (mutable-custom-set? x)
|
||||
(eq? (custom-set-spec x) spec)))
|
||||
(procedure-rename proc name))
|
||||
|
||||
(define (immutable-custom-set-predicate spec name)
|
||||
(define (proc x)
|
||||
(dprintf "~a\n" name)
|
||||
(and (immutable-custom-set? x)
|
||||
(eq? (custom-set-spec x) spec)))
|
||||
(procedure-rename proc name))
|
||||
|
||||
(define (immutable-custom-set-maker spec name)
|
||||
(define (proc [st '()])
|
||||
(dprintf "~a\n" name)
|
||||
(define table
|
||||
(for/fold ([table (make-immutable-hash)]) ([x (in-stream st)])
|
||||
(check-elem name spec x)
|
||||
(hash-set table (wrap-elem spec x) #t)))
|
||||
(immutable-custom-set spec table))
|
||||
(procedure-rename proc name))
|
||||
|
||||
(define (imperative-custom-set-maker spec name make-table make-set)
|
||||
(define (proc [st '()])
|
||||
(dprintf "~a\n" name)
|
||||
(define table (make-table))
|
||||
(for ([x (in-stream st)])
|
||||
(check-elem name spec x)
|
||||
(hash-set! table (wrap-elem spec x) #t))
|
||||
(make-set spec table))
|
||||
(procedure-rename proc name))
|
||||
|
||||
(define (mutable-custom-set-maker spec name)
|
||||
(imperative-custom-set-maker spec name make-hash mutable-custom-set))
|
||||
|
||||
(define (weak-custom-set-maker spec name)
|
||||
(imperative-custom-set-maker spec name make-weak-hash weak-custom-set))
|
||||
|
||||
(define dprintf void)
|
||||
|
||||
(define (make-immutable-set spec make-table st)
|
||||
(define table
|
||||
(for/fold ([table (make-table)]) ([x (in-stream st)])
|
||||
(hash-set table (wrap-elem spec x) #t)))
|
||||
(immutable-custom-set spec table))
|
||||
|
||||
(define (make-imperative-set spec make-table make-set st)
|
||||
(define table (make-table))
|
||||
(for ([x (in-stream st)])
|
||||
(hash-set! table (wrap-elem spec x) #t))
|
||||
(make-set spec table))
|
||||
|
||||
(define (make-mutable-set spec make-table st)
|
||||
(make-imperative-set spec make-table mutable-custom-set st))
|
||||
|
||||
(define (make-weak-set spec make-table st)
|
||||
(make-imperative-set spec make-table weak-custom-set st))
|
||||
|
||||
(define (list->set xs)
|
||||
(dprintf "list->set\n")
|
||||
(make-immutable-set #f make-immutable-hash xs))
|
||||
(define (list->seteq xs)
|
||||
(dprintf "list->seteq\n")
|
||||
(make-immutable-set #f make-immutable-hasheq xs))
|
||||
(define (list->seteqv xs)
|
||||
(dprintf "list->seteqv\n")
|
||||
(make-immutable-set #f make-immutable-hasheqv xs))
|
||||
(define (list->weak-set xs)
|
||||
(dprintf "list->weak-set\n")
|
||||
(make-weak-set #f make-weak-hash xs))
|
||||
(define (list->weak-seteq xs)
|
||||
(dprintf "list->weak-seteq\n")
|
||||
(make-weak-set #f make-weak-hasheq xs))
|
||||
(define (list->weak-seteqv xs)
|
||||
(dprintf "list->weak-seteqv\n")
|
||||
(make-weak-set #f make-weak-hasheqv xs))
|
||||
(define (list->mutable-set xs)
|
||||
(dprintf "list->mutable-set\n")
|
||||
(make-mutable-set #f make-hash xs))
|
||||
(define (list->mutable-seteq xs)
|
||||
(dprintf "list->mutable-seteq\n")
|
||||
(make-mutable-set #f make-hasheq xs))
|
||||
(define (list->mutable-seteqv xs)
|
||||
(dprintf "list->mutable-seteqv\n")
|
||||
(make-mutable-set #f make-hasheqv xs))
|
||||
|
||||
(define (set . xs)
|
||||
(dprintf "set\n")
|
||||
(list->set xs))
|
||||
(define (seteq . xs)
|
||||
(dprintf "seteq\n")
|
||||
(list->seteq xs))
|
||||
(define (seteqv . xs)
|
||||
(dprintf "seteqv\n")
|
||||
(list->seteqv xs))
|
||||
(define (weak-set . xs)
|
||||
(dprintf "weak-set\n")
|
||||
(list->weak-set xs))
|
||||
(define (weak-seteq . xs)
|
||||
(dprintf "weak-seteq\n")
|
||||
(list->weak-seteq xs))
|
||||
(define (weak-seteqv . xs)
|
||||
(dprintf "weak-seteqv\n")
|
||||
(list->weak-seteqv xs))
|
||||
(define (mutable-set . xs)
|
||||
(dprintf "mutable-set\n")
|
||||
(list->mutable-set xs))
|
||||
(define (mutable-seteq . xs)
|
||||
(dprintf "mutable-seteq\n")
|
||||
(list->mutable-seteq xs))
|
||||
(define (mutable-seteqv . xs)
|
||||
(dprintf "mutable-seteqv\n")
|
||||
(list->mutable-seteqv xs))
|
||||
|
||||
(define (set-eq? x)
|
||||
(dprintf "set-eq?\n")
|
||||
(and (custom-set? x) (hash-eq? (custom-set-table x))))
|
||||
(define (set-eqv? x)
|
||||
(dprintf "set-eqv?\n")
|
||||
(and (custom-set? x) (hash-eqv? (custom-set-table x))))
|
||||
(define (set-equal? x)
|
||||
(dprintf "set-equal?\n")
|
||||
(and (custom-set? x) (hash-equal? (custom-set-table x))))
|
||||
|
||||
(define (set-immutable? x)
|
||||
(dprintf "set-immutable?\n")
|
||||
(immutable-custom-set? x))
|
||||
(define (set-mutable? x)
|
||||
(dprintf "set-mutable?\n")
|
||||
(mutable-custom-set? x))
|
||||
(define (set-weak? x)
|
||||
(dprintf "set-weak?\n")
|
||||
(weak-custom-set? x))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define (immutable-for for-id table-id)
|
||||
(with-syntax ([for_/fold/derived for-id]
|
||||
[make-table table-id])
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(form clauses body ... expr)
|
||||
(with-syntax ([original stx])
|
||||
(syntax-protect
|
||||
#'(immutable-custom-set
|
||||
(begin0 #f (dprintf "~a\n" 'form))
|
||||
(for_/fold/derived original ([table (make-table)]) clauses
|
||||
body ...
|
||||
(hash-set table expr #t)))))]))))
|
||||
|
||||
(define (immutable-fors table-id)
|
||||
(values (immutable-for #'for/fold/derived table-id)
|
||||
(immutable-for #'for*/fold/derived table-id)))
|
||||
|
||||
(define (imperative-for for-id table-id set-id)
|
||||
(with-syntax ([for_/fold/derived for-id]
|
||||
[make-set set-id]
|
||||
[make-table table-id])
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(form clauses body ... expr)
|
||||
(with-syntax ([original stx])
|
||||
(syntax-protect
|
||||
#'(let ([table (make-table)])
|
||||
(dprintf "~a\n" 'form)
|
||||
(for_/fold/derived original () clauses
|
||||
body ...
|
||||
(hash-set! table expr #t)
|
||||
(values))
|
||||
(make-set #f table))))]))))
|
||||
|
||||
(define (imperative-fors table-id set-id)
|
||||
(values (imperative-for #'for/fold/derived table-id set-id)
|
||||
(imperative-for #'for*/fold/derived table-id set-id)))
|
||||
|
||||
(define (mutable-fors table-id)
|
||||
(imperative-fors table-id #'mutable-custom-set))
|
||||
(define (weak-fors table-id)
|
||||
(imperative-fors table-id #'weak-custom-set)))
|
||||
|
||||
(define-syntaxes (for/set for*/set)
|
||||
(immutable-fors #'make-immutable-hash))
|
||||
(define-syntaxes (for/seteq for*/seteq)
|
||||
(immutable-fors #'make-immutable-hasheq))
|
||||
(define-syntaxes (for/seteqv for*/seteqv)
|
||||
(immutable-fors #'make-immutable-hasheqv))
|
||||
|
||||
(define-syntaxes (for/weak-set for*/weak-set)
|
||||
(weak-fors #'make-weak-hash))
|
||||
(define-syntaxes (for/weak-seteq for*/weak-seteq)
|
||||
(weak-fors #'make-weak-hasheq))
|
||||
(define-syntaxes (for/weak-seteqv for*/weak-seteqv)
|
||||
(weak-fors #'make-weak-hasheqv))
|
||||
|
||||
(define-syntaxes (for/mutable-set for*/mutable-set)
|
||||
(mutable-fors #'make-hash))
|
||||
(define-syntaxes (for/mutable-seteq for*/mutable-seteq)
|
||||
(mutable-fors #'make-hasheq))
|
||||
(define-syntaxes (for/mutable-seteqv for*/mutable-seteqv)
|
||||
(mutable-fors #'make-hasheqv))
|
||||
532
racket/collects/racket/private/set.rkt
Normal file
532
racket/collects/racket/private/set.rkt
Normal file
|
|
@ -0,0 +1,532 @@
|
|||
#lang racket/base
|
||||
(require racket/contract
|
||||
racket/generic
|
||||
racket/stream
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide gen:set set? set-implements?
|
||||
|
||||
set-empty? set-member? set-count
|
||||
set=? subset? proper-subset?
|
||||
set-map set-for-each
|
||||
set-copy set->list set->stream set-first set-rest
|
||||
set-add set-remove set-clear
|
||||
set-union set-intersect set-subtract set-symmetric-difference
|
||||
set-add! set-remove! set-clear!
|
||||
set-union! set-intersect! set-subtract! set-symmetric-difference!
|
||||
|
||||
(rename-out [*in-set in-set])
|
||||
primitive-set/c
|
||||
set-implements/c)
|
||||
|
||||
;; Method implementations for lists:
|
||||
|
||||
(define (list-member? s x) (pair? (member x s)))
|
||||
|
||||
(define (list-set=? s1 s2)
|
||||
(unless (list? s2)
|
||||
(raise-argument-error 'set=? "list?" s2))
|
||||
(and (for/and ([x (in-list s1)]) (member x s2))
|
||||
(for/and ([x (in-list s2)]) (member x s1))
|
||||
#t))
|
||||
|
||||
(define (list-subset? s1 s2)
|
||||
(unless (list? s2)
|
||||
(raise-argument-error 'subset? "list?" s2))
|
||||
(and (for/and ([x (in-list s1)]) (member x s2))
|
||||
#t))
|
||||
|
||||
(define (list-proper-subset? s1 s2)
|
||||
(unless (list? s2)
|
||||
(raise-argument-error 'proper-subset? "list?" s2))
|
||||
(and (for/and ([x (in-list s1)]) (member x s2))
|
||||
(for/or ([x (in-list s2)]) (not (member x s1)))
|
||||
#t))
|
||||
|
||||
(define (list-map s f) (map f s))
|
||||
|
||||
(define (list-for-each s f) (for-each f s))
|
||||
|
||||
(define (list-add s x)
|
||||
(if (member x s) s (cons x s)))
|
||||
|
||||
(define (list-remove s . xs) (remove* xs s))
|
||||
|
||||
(define (list-clear s) '())
|
||||
|
||||
(define (list-union s . sets)
|
||||
(for/fold ([s1 s]) ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-union "list?" i s sets))
|
||||
(for/fold ([s1 s1]) ([x (in-list s2)])
|
||||
(list-add s1 x))))
|
||||
|
||||
(define (list-intersect s . sets)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (list? s2)
|
||||
(apply raise-argument-error 'set-intersect "list?" i s sets)))
|
||||
(for/fold
|
||||
([s1 '()])
|
||||
([x (in-list s)]
|
||||
#:when (for/and ([s2 (in-list sets)])
|
||||
(member x s2)))
|
||||
(list-add s1 x)))
|
||||
|
||||
(define (list-subtract s . sets)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (list? s2)
|
||||
(apply raise-argument-error 'set-subtract "list?" i s sets)))
|
||||
(for/fold
|
||||
([s1 '()])
|
||||
([x (in-list s)]
|
||||
#:unless (for/or ([s2 (in-list sets)])
|
||||
(member x s2)))
|
||||
(list-add s1 x)))
|
||||
|
||||
(define (list-symmetric-difference s . sets)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (list? s2)
|
||||
(apply raise-argument-error 'set-symmetric-difference "list?" i s sets)))
|
||||
(for*/fold
|
||||
([s1 s])
|
||||
([s2 (in-list sets)]
|
||||
[x (in-list s2)])
|
||||
(if (list-member? s1 x)
|
||||
(list-remove s1 x)
|
||||
(list-add s1 x))))
|
||||
|
||||
;; Fallback method implementations:
|
||||
|
||||
(define (fallback-empty? s)
|
||||
(cond
|
||||
[(set-implements? s 'set->stream)
|
||||
(stream-empty? (set->stream s))]
|
||||
[(set-implements? s 'set-count)
|
||||
(zero? (set-count s))]
|
||||
[else (raise-support-error 'set-empty? s)]))
|
||||
|
||||
(define (fallback-first s)
|
||||
(cond
|
||||
[(set-implements? s 'set->stream)
|
||||
(stream-first (set->stream s))]
|
||||
[else (raise-support-error 'set-first s)]))
|
||||
|
||||
(define (fallback-rest s)
|
||||
(cond
|
||||
[(set-implements? s 'set-remove 'set-first)
|
||||
(set-remove s (set-first s))]
|
||||
[(set-implements? s 'set-remove 'set->stream)
|
||||
(set-remove s (stream-first (set->stream s)))]
|
||||
[else (raise-support-error 'set-rest s)]))
|
||||
|
||||
(define (fallback->stream s)
|
||||
(cond
|
||||
[(set-implements? s 'in-set) (sequence->stream (in-set s))]
|
||||
[(set-implements? s 'set-empty? 'set-first 'set-rest)
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(stream-empty? s) empty-stream]
|
||||
[else (stream-cons (set-first s)
|
||||
(loop (set-rest s)))]))]
|
||||
[(set-implements? s 'set-empty? 'set-first 'set-remove)
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(stream-empty? s) empty-stream]
|
||||
[else (stream-cons (set-first s)
|
||||
(loop (set-remove s (set-first s))))]))]
|
||||
[(set-implements? s 'set-count 'set-first 'set-rest)
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(zero? (set-count s)) empty-stream]
|
||||
[else (stream-cons (set-first s)
|
||||
(loop (set-rest s)))]))]
|
||||
[(set-implements? s 'set-count 'set-first 'set-remove)
|
||||
(let loop ([s s])
|
||||
(cond
|
||||
[(zero? (set-count s)) empty-stream]
|
||||
[else (stream-cons (set-first s)
|
||||
(loop (set-remove s (set-first s))))]))]
|
||||
[(set-implements? s 'set->list) (set->list s)]
|
||||
[else (raise-support-error 'set->stream s)]))
|
||||
|
||||
(define (fallback-in-set s)
|
||||
(cond
|
||||
[(set-implements? s 'set->stream) (set->stream s)]
|
||||
[(set-implements? s 'set-empty? 'set-first 'set-rest)
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(values set-first
|
||||
set-rest
|
||||
s
|
||||
(lambda (s) (not (set-empty? s)))
|
||||
#f
|
||||
#f)))]
|
||||
[(set-implements? s 'set-empty? 'set-first 'set-remove)
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(values set-first
|
||||
(lambda (s) (set-remove s (set-first s)))
|
||||
s
|
||||
(lambda (s) (not (set-empty? s)))
|
||||
#f
|
||||
#f)))]
|
||||
[(set-implements? s 'set-count 'set-first 'set-rest)
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(values set-first
|
||||
set-rest
|
||||
s
|
||||
(lambda (s) (not (zero? (set-count s))))
|
||||
#f
|
||||
#f)))]
|
||||
[(set-implements? s 'set-count 'set-first 'set-remove)
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(values set-first
|
||||
(lambda (s) (set-remove s (set-first s)))
|
||||
s
|
||||
(lambda (s) (not (zero? (set-count s))))
|
||||
#f
|
||||
#f)))]
|
||||
[(set-implements? s 'set->list) (set->list s)]
|
||||
[else (raise-support-error 'in-set s)]))
|
||||
|
||||
(define (fallback-count s)
|
||||
(for/sum ([x (*in-set s)]) 1))
|
||||
|
||||
(define (fallback-set=? s1 s2)
|
||||
(unless (set? s2)
|
||||
(raise-argument-error 'set=? "set?" 1 s1 s2))
|
||||
(or (eq? s1 s2)
|
||||
(cond
|
||||
[(set-implements? s2 'set=?) (set=? s1 s2)]
|
||||
[else (and (subset? s1 s2)
|
||||
(subset? s2 s1))])))
|
||||
|
||||
(define (fallback-proper-subset? s1 s2)
|
||||
(unless (set? s2)
|
||||
(raise-argument-error 'proper-subset? "set?" 1 s1 s2))
|
||||
(and (subset? s1 s2)
|
||||
(not (subset? s2 s1))))
|
||||
|
||||
(define (fallback-subset? s1 s2)
|
||||
(unless (set? s2)
|
||||
(raise-argument-error 'subset? "set?" 1 s1 s2))
|
||||
(for/and ([x (*in-set s1)])
|
||||
(set-member? s2 x)))
|
||||
|
||||
(define (fallback-map s f)
|
||||
(for/list ([x (*in-set s)])
|
||||
(f x)))
|
||||
|
||||
(define (fallback-for-each s f)
|
||||
(for ([x (*in-set s)])
|
||||
(f x)))
|
||||
|
||||
(define (fallback-copy s)
|
||||
(cond
|
||||
[(set-implements? s 'set-clear 'set-add!)
|
||||
(define s2 (set-clear s))
|
||||
(for ([x (*in-set s)])
|
||||
(set-add! s2 x))
|
||||
s2]
|
||||
[else (raise-support-error 'set-copy s)]))
|
||||
|
||||
(define (fallback->list s)
|
||||
(for/list ([x (*in-set s)])
|
||||
x))
|
||||
|
||||
(define (fallback-clear s)
|
||||
(cond
|
||||
[(set-implements? s 'set-remove)
|
||||
(for/fold ([s s]) ([x (*in-set s)])
|
||||
(set-remove s x))]
|
||||
[else (raise-support-error 'set-clear s)]))
|
||||
|
||||
(define (fallback-union s . sets)
|
||||
(cond
|
||||
[(set-implements? s 'set-add)
|
||||
(for/fold ([s1 s]) ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-union "set?" i s sets))
|
||||
(for/fold ([s1 s1]) ([x (*in-set s2)])
|
||||
(set-add s1 x)))]
|
||||
[else (raise-support-error 'set-union s)]))
|
||||
|
||||
(define (fallback-intersect s . sets)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-intersect "set?" i s sets)))
|
||||
(define (keep? x)
|
||||
(for/and ([s2 (in-list sets)])
|
||||
(set-member? s2 x)))
|
||||
(cond
|
||||
[(set-implements? s 'set-remove)
|
||||
(for/fold ([s1 s]) ([x (*in-set s)] #:unless (keep? x))
|
||||
(set-remove s1 x))]
|
||||
[(set-implements? s 'set-add 'set-clear)
|
||||
(for/fold ([s1 (set-clear s)]) ([x (*in-set s)] #:when (keep? x))
|
||||
(set-add s1 x))]
|
||||
[else (raise-support-error 'set-intersect s)]))
|
||||
|
||||
(define (fallback-subtract s . sets)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-subtract "set?" i s sets)))
|
||||
(define (remove? x)
|
||||
(for/or ([s2 (in-list sets)])
|
||||
(set-member? s2 x)))
|
||||
(cond
|
||||
[(set-implements? s 'set-remove)
|
||||
(for/fold ([s1 s]) ([x (*in-set s)] #:when (remove? x))
|
||||
(set-remove s1 x))]
|
||||
[(set-implements? s 'set-add 'set-clear)
|
||||
(for/fold ([s1 (set-clear s)]) ([x (*in-set s)] #:unless (remove? x))
|
||||
(set-add s1 x))]
|
||||
[else (raise-support-error 'set-subtract s)]))
|
||||
|
||||
(define (fallback-symmetric-difference s . sets)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-symmetric-difference "set?" i s sets)))
|
||||
(define (keep? x)
|
||||
(even?
|
||||
(for/sum ([s2 (in-list sets)]
|
||||
#:when (set-member? s2 x))
|
||||
1)))
|
||||
(cond
|
||||
[(set-implements? s 'set-remove)
|
||||
(for/fold ([s1 s]) ([x (*in-set s)] #:unless (keep? x))
|
||||
(set-remove s1 x))]
|
||||
[(set-implements? s 'set-add 'set-clear)
|
||||
(for/fold ([s1 (set-clear s)]) ([x (*in-set s)] #:when (keep? x))
|
||||
(set-add s1 x))]
|
||||
[else (raise-support-error 'set-symmetric-difference s)]))
|
||||
|
||||
(define (fallback-clear! s)
|
||||
(cond
|
||||
[(set-implements? s 'set-remove! 'set-empty? 'set-first)
|
||||
(let loop ()
|
||||
(unless (set-empty? s)
|
||||
(set-remove! s (set-first s))
|
||||
(loop)))]
|
||||
[(set-implements? s 'set-remove! 'set->stream)
|
||||
(let loop ()
|
||||
(define st (set->stream s))
|
||||
(unless (stream-empty? st)
|
||||
(set-remove! s (stream-first st))
|
||||
(loop)))]
|
||||
[(set-implements? s 'set-remove! 'set-count 'set-first)
|
||||
(let loop ()
|
||||
(unless (zero? (set-count s))
|
||||
(set-remove! s (set-first s))
|
||||
(loop)))]
|
||||
[(set-implements? s 'set-remove! 'set->list)
|
||||
(for ([x (in-list (set->list s))])
|
||||
(set-remove! s x))]
|
||||
[else (raise-support-error 'set-clear! s)]))
|
||||
|
||||
(define (fallback-union! s . sets)
|
||||
(cond
|
||||
[(set-implements? s 'set-add!)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-union! "set?" i s sets))
|
||||
(for ([x (*in-set s2)])
|
||||
(set-add! s x)))]
|
||||
[else (raise-support-error 'set-union! s)]))
|
||||
|
||||
(define (fallback-intersect! s . sets)
|
||||
(cond
|
||||
[(set-implements? s 'set-remove!)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-intersect! "set?" i s sets)))
|
||||
(define (keep? x)
|
||||
(for/and ([s2 (in-list sets)])
|
||||
(set-member? s2 x)))
|
||||
(define to-remove
|
||||
(for/list ([x (*in-set s)] #:unless (keep? x))
|
||||
x))
|
||||
(for ([x (in-list to-remove)])
|
||||
(set-remove! s x))]
|
||||
[else (raise-support-error 'set-intersect! s)]))
|
||||
|
||||
(define (fallback-subtract! s . sets)
|
||||
(cond
|
||||
[(set-implements? s 'set-remove!)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(apply raise-argument-error 'set-subtract! "set?" i s sets)))
|
||||
(define (remove? x)
|
||||
(for/or ([s2 (in-list sets)])
|
||||
(set-member? s2 x)))
|
||||
(define to-remove
|
||||
(for/list ([x (*in-set s)] #:when (remove? x))
|
||||
x))
|
||||
(for ([x (in-list to-remove)])
|
||||
(set-remove! s x))]
|
||||
[else (raise-support-error 'set-subtract! s)]))
|
||||
|
||||
(define (fallback-symmetric-difference! s . sets)
|
||||
(cond
|
||||
[(set-implements? s 'set-remove!)
|
||||
(for ([s2 (in-list sets)] [i (in-naturals 1)])
|
||||
(unless (set? s2)
|
||||
(define name 'set-symmetric-difference!)
|
||||
(apply raise-argument-error name "set?" i s sets)))
|
||||
(define (keep? x)
|
||||
(even?
|
||||
(for/sum ([s2 (in-list sets)]
|
||||
#:when (set-member? s2 x))
|
||||
1)))
|
||||
(define to-remove
|
||||
(for/list ([x (*in-set s)] #:unless (keep? x))
|
||||
x))
|
||||
(for ([x (in-list to-remove)])
|
||||
(set-remove! s x))]
|
||||
[else (raise-support-error 'set-symmetric-difference! s)]))
|
||||
|
||||
(define (raise-support-error name s)
|
||||
(raise-mismatch-error name "not implemented for " s))
|
||||
|
||||
(define-sequence-syntax *in-set
|
||||
(lambda () #'in-set)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[[(x) (_ e)]
|
||||
#'[(x) (in-set e)]]
|
||||
[_ #f])))
|
||||
|
||||
(define (set-implements/c . syms)
|
||||
(if (null? syms)
|
||||
set?
|
||||
(flat-named-contract
|
||||
`(set-implements/c . ,syms)
|
||||
(lambda (x)
|
||||
(and (set? x)
|
||||
(for/and ([sym (in-list syms)])
|
||||
(set-implements? x sym)))))))
|
||||
|
||||
(define (primitive-set/c elem/c)
|
||||
(define (proc)
|
||||
(set/c
|
||||
[set-member? (-> set? elem/c boolean?)]
|
||||
[set-empty? (or/c (-> set? boolean?) #f)]
|
||||
[set-count (or/c (-> set? exact-nonnegative-integer?) #f)]
|
||||
[set=? (or/c (-> set? c boolean?) #f)]
|
||||
[subset? (or/c (-> set? c boolean?) #f)]
|
||||
[proper-subset? (or/c (-> set? c boolean?) #f)]
|
||||
[set-map (or/c (-> set? (-> elem/c any/c) list?) #f)]
|
||||
[set-for-each (or/c (-> set? (-> elem/c any) void?) #f)]
|
||||
[set-copy (or/c (-> set? c) #f)]
|
||||
[in-set (or/c (-> set? sequence?) #f)]
|
||||
[set->list (or/c (-> set? list?) #f)]
|
||||
[set->stream (or/c (-> set? stream?) #f)]
|
||||
[set-first (or/c (-> set? elem/c) #f)]
|
||||
[set-rest (or/c (-> set? c) #f)]
|
||||
[set-add (or/c (-> set? elem/c c) #f)]
|
||||
[set-remove (or/c (-> set? elem/c c) #f)]
|
||||
[set-clear (or/c (-> set? c) #f)]
|
||||
[set-union (or/c (->* [set?] [] #:rest (listof c) c) #f)]
|
||||
[set-intersect (or/c (->* [set?] [] #:rest (listof c) c) #f)]
|
||||
[set-subtract (or/c (->* [set?] [] #:rest (listof c) c) #f)]
|
||||
[set-symmetric-difference (or/c (->* [set?] [] #:rest (listof c) c) #f)]
|
||||
[set-add! (or/c (-> set? elem/c void?) #f)]
|
||||
[set-remove! (or/c (-> set? elem/c void?) #f)]
|
||||
[set-clear! (or/c (-> set? void?) #f)]
|
||||
[set-union! (or/c (->* [set?] [] #:rest (listof c) void?) #f)]
|
||||
[set-intersect! (or/c (->* [set?] [] #:rest (listof c) void?) #f)]
|
||||
[set-subtract! (or/c (->* [set?] [] #:rest (listof c) void?) #f)]
|
||||
[set-symmetric-difference!
|
||||
(or/c (->* [set?] [] #:rest (listof c) void?) #f)]))
|
||||
(define c
|
||||
(cond
|
||||
[(chaperone-contract? elem/c)
|
||||
(recursive-contract (proc) #:chaperone)]
|
||||
[else
|
||||
(recursive-contract (proc) #:impersonator)]))
|
||||
(or/c (listof elem/c)
|
||||
(and/c set? c)))
|
||||
|
||||
;; Generics definition:
|
||||
|
||||
(define-generics set
|
||||
#:defined-predicate set-implements?
|
||||
|
||||
(set-empty? set)
|
||||
(set-member? set x)
|
||||
(set-count set)
|
||||
(set=? set set2)
|
||||
(subset? set set2)
|
||||
(proper-subset? set set2)
|
||||
(set-map set f)
|
||||
(set-for-each set f)
|
||||
(set-copy set)
|
||||
(in-set set)
|
||||
(set->list set)
|
||||
(set->stream set)
|
||||
(set-first set)
|
||||
(set-rest set)
|
||||
(set-add set x)
|
||||
(set-remove set x)
|
||||
(set-clear set)
|
||||
(set-union set . sets)
|
||||
(set-intersect set . sets)
|
||||
(set-subtract set . sets)
|
||||
(set-symmetric-difference set . sets)
|
||||
(set-add! set x)
|
||||
(set-remove! set x)
|
||||
(set-clear! set)
|
||||
(set-union! set . sets)
|
||||
(set-intersect! set . sets)
|
||||
(set-subtract! set . sets)
|
||||
(set-symmetric-difference! set . sets)
|
||||
|
||||
#:fast-defaults
|
||||
([list?
|
||||
(define set-empty? null?)
|
||||
(define set-member? list-member?)
|
||||
(define set-count length)
|
||||
(define set=? list-set=?)
|
||||
(define subset? list-subset?)
|
||||
(define proper-subset? list-proper-subset?)
|
||||
(define set-map list-map)
|
||||
(define set-for-each list-for-each)
|
||||
(define in-set in-list)
|
||||
(define set->list values)
|
||||
(define set->stream values)
|
||||
(define set-first car)
|
||||
(define set-rest cdr)
|
||||
(define set-add list-add)
|
||||
(define set-remove list-remove)
|
||||
(define set-clear list-clear)
|
||||
(define set-union list-union)
|
||||
(define set-intersect list-intersect)
|
||||
(define set-subtract list-subtract)
|
||||
(define set-symmetric-difference list-symmetric-difference)])
|
||||
|
||||
#:fallbacks
|
||||
[(define set-empty? fallback-empty?)
|
||||
(define set-count fallback-count)
|
||||
(define set=? fallback-set=?)
|
||||
(define subset? fallback-subset?)
|
||||
(define proper-subset? fallback-proper-subset?)
|
||||
(define set-map fallback-map)
|
||||
(define set-for-each fallback-for-each)
|
||||
(define set-copy fallback-copy)
|
||||
(define in-set fallback-in-set)
|
||||
(define set->list fallback->list)
|
||||
(define set->stream fallback->stream)
|
||||
(define set-first fallback-first)
|
||||
(define set-rest fallback-rest)
|
||||
(define set-clear fallback-clear)
|
||||
(define set-union fallback-union)
|
||||
(define set-intersect fallback-intersect)
|
||||
(define set-subtract fallback-subtract)
|
||||
(define set-symmetric-difference fallback-symmetric-difference)
|
||||
(define set-clear! fallback-clear!)
|
||||
(define set-union! fallback-union!)
|
||||
(define set-intersect! fallback-intersect!)
|
||||
(define set-subtract! fallback-subtract!)
|
||||
(define set-symmetric-difference! fallback-symmetric-difference!)])
|
||||
|
|
@ -1,506 +1,71 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/for-body)
|
||||
racket/serialize
|
||||
racket/pretty
|
||||
racket/contract/base
|
||||
racket/contract/combinator
|
||||
(only-in "private/for.rkt" prop:stream))
|
||||
|
||||
(provide set seteq seteqv
|
||||
set? set-eq? set-eqv? set-equal?
|
||||
set-empty? set-count
|
||||
set-member? set-add set-remove
|
||||
set-first set-rest
|
||||
set-union set-intersect set-subtract set-symmetric-difference
|
||||
subset? proper-subset?
|
||||
set-map set-for-each
|
||||
(rename-out [*in-set in-set])
|
||||
for/set for/seteq for/seteqv
|
||||
for*/set for*/seteq for*/seteqv
|
||||
(rename-out [*set/c set/c])
|
||||
set=?
|
||||
set->list
|
||||
list->set list->seteq list->seteqv)
|
||||
(require racket/contract
|
||||
racket/private/set
|
||||
racket/private/set-types)
|
||||
|
||||
(define-serializable-struct set (ht)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:custom-print-quotable 'never
|
||||
#:property prop:custom-write
|
||||
(lambda (s port mode)
|
||||
(define recur-print (cond
|
||||
[(not mode) display]
|
||||
[(integer? mode) (lambda (p port) (print p port mode))]
|
||||
[else write]))
|
||||
(define (print-prefix port)
|
||||
(cond
|
||||
[(equal? 0 mode)
|
||||
(write-string "(set" port)
|
||||
(print-prefix-id port)]
|
||||
[else
|
||||
(write-string "#<set" port)
|
||||
(print-prefix-id port)
|
||||
(write-string ":" port)]))
|
||||
(define (print-prefix-id port)
|
||||
(cond
|
||||
[(set-equal? s) (void)]
|
||||
[(set-eqv? s) (write-string "eqv" port)]
|
||||
[(set-eq? s) (write-string "eq" port)]))
|
||||
(define (print-suffix port)
|
||||
(if (equal? 0 mode)
|
||||
(write-string ")" port)
|
||||
(write-string ">" port)))
|
||||
(define (print-one-line port)
|
||||
(print-prefix port)
|
||||
(set-for-each s
|
||||
(lambda (e)
|
||||
(write-string " " port)
|
||||
(recur-print e port)))
|
||||
(print-suffix port))
|
||||
(define (print-multi-line port)
|
||||
(let-values ([(line col pos) (port-next-location port)])
|
||||
(print-prefix port)
|
||||
(set-for-each s
|
||||
(lambda (e)
|
||||
(pretty-print-newline port (pretty-print-columns))
|
||||
(write-string (make-string (add1 col) #\space) port)
|
||||
(recur-print e port)))
|
||||
(print-suffix port)))
|
||||
(provide (except-out (all-from-out racket/private/set)
|
||||
primitive-set/c)
|
||||
(all-from-out racket/private/set-types)
|
||||
set/c)
|
||||
|
||||
(define (set/c elem/c
|
||||
#:cmp [cmp 'dont-care]
|
||||
#:kind [kind 'dont-care])
|
||||
(define cmp/c
|
||||
(case cmp
|
||||
[(dont-care) any/c]
|
||||
[(equal) set-equal?]
|
||||
[(eqv) set-eqv?]
|
||||
[(eq) set-eq?]
|
||||
[else (raise-arguments-error 'set/c
|
||||
"invalid #:cmp argument"
|
||||
"#:cmp argument" cmp)]))
|
||||
(define kind/c
|
||||
(case kind
|
||||
[(dont-care) any/c]
|
||||
[(mutable-or-weak) (or/c set-weak? set-mutable?)]
|
||||
[(mutable) set-mutable?]
|
||||
[(weak) set-weak?]
|
||||
[(immutable) set-immutable?]
|
||||
[else (raise-arguments-error 'set/c
|
||||
"invalid #:kind argument"
|
||||
"#:kind argument" kind)]))
|
||||
(case cmp
|
||||
[(eqv eq)
|
||||
(unless (flat-contract? elem/c)
|
||||
(raise-arguments-error
|
||||
'set/c
|
||||
"element contract must be a flat contract for eqv? and eq?-based sets"
|
||||
"element contract" (contract-name elem/c)
|
||||
"#:cmp option" cmp))]
|
||||
[else
|
||||
(unless (contract? elem/c)
|
||||
(raise-argument-error 'set/c "contract?" elem/c))])
|
||||
(define c
|
||||
(and/c (primitive-set/c elem/c)
|
||||
cmp/c
|
||||
kind/c))
|
||||
(define name
|
||||
`(set/c ,(contract-name elem/c)
|
||||
,@(if (eq? cmp 'dont-care)
|
||||
`[]
|
||||
`[#:cmp (quote #,cmp)])
|
||||
,@(if (eq? kind 'dont-care)
|
||||
`[]
|
||||
`[#:kind (quote #,kind)])))
|
||||
(rename-contract c name))
|
||||
|
||||
(define (rename-contract c name)
|
||||
(define make
|
||||
(cond
|
||||
[(and (pretty-printing)
|
||||
(integer? (pretty-print-columns)))
|
||||
((let/ec esc
|
||||
(letrec ([tport (make-tentative-pretty-print-output-port
|
||||
port
|
||||
(- (pretty-print-columns) 1)
|
||||
(lambda ()
|
||||
(esc
|
||||
(lambda ()
|
||||
(tentative-pretty-print-port-cancel tport)
|
||||
(print-multi-line port)))))])
|
||||
(print-one-line tport)
|
||||
(tentative-pretty-print-port-transfer tport port))
|
||||
void))]
|
||||
[else (print-one-line port)]))
|
||||
#:property prop:equal+hash (list
|
||||
(lambda (set1 set2 =?)
|
||||
(=? (set-ht set1) (set-ht set2)))
|
||||
(lambda (set hc) (add1 (hc (set-ht set))))
|
||||
(lambda (set hc) (add1 (hc (set-ht set)))))
|
||||
#:property prop:sequence (lambda (v) (*in-set v))
|
||||
#:property prop:stream (vector (lambda (s) (set-empty? s))
|
||||
(lambda (s) (set-first s))
|
||||
(lambda (s) (set-rest s))))
|
||||
|
||||
;; Not currently exporting this because I'm not sure whether this is the right semantics
|
||||
;; for it yet, but it follows most closely the semantics of the old set/c implementation
|
||||
;; (while still returning a chaperone).
|
||||
(define (chaperone-set s elem-chaperone)
|
||||
(when (or (set-eq? s)
|
||||
(set-eqv? s))
|
||||
(raise-argument-error 'chaperone-set "(and/c set? set-equal?)" s))
|
||||
(chaperone-struct s
|
||||
set-ht
|
||||
(let ([cached-ht #f])
|
||||
(λ (st ht)
|
||||
(if cached-ht cached-ht
|
||||
(let ([new-ht (make-immutable-hash
|
||||
(hash-map ht (λ (k v)
|
||||
;; should be a check of the return here,
|
||||
;; but until this is exported, it's only
|
||||
;; used by set/c, which is sure to pass
|
||||
;; a chaperone-respecting function.
|
||||
(cons (elem-chaperone s k) v))))])
|
||||
(set! cached-ht new-ht)
|
||||
new-ht))))))
|
||||
|
||||
(define (set . elems)
|
||||
(make-set (make-immutable-hash (map (lambda (k) (cons k #t)) elems))))
|
||||
(define (seteq . elems)
|
||||
(make-set (make-immutable-hasheq (map (lambda (k) (cons k #t)) elems))))
|
||||
(define (seteqv . elems)
|
||||
(make-set (make-immutable-hasheqv (map (lambda (k) (cons k #t)) elems))))
|
||||
|
||||
(define (set-eq? set)
|
||||
(unless (set? set) (raise-argument-error 'set-eq? "set?" 0 set))
|
||||
(hash-eq? (set-ht set)))
|
||||
(define (set-eqv? set)
|
||||
(unless (set? set) (raise-argument-error 'set-eqv? "set?" 0 set))
|
||||
(hash-eqv? (set-ht set)))
|
||||
(define (set-equal? set)
|
||||
(unless (set? set) (raise-argument-error 'set-equal? "set?" 0 set))
|
||||
(let* ([ht (set-ht set)])
|
||||
(not (or (hash-eq? ht)
|
||||
(hash-eqv? ht)))))
|
||||
|
||||
(define (set-empty? set)
|
||||
(unless (set? set) (raise-argument-error 'set-empty? "set?" 0 set))
|
||||
(zero? (hash-count (set-ht set))))
|
||||
|
||||
(define (set-count set)
|
||||
(unless (set? set) (raise-argument-error 'set-count "set?" 0 set))
|
||||
(hash-count (set-ht set)))
|
||||
|
||||
(define (set-member? set v)
|
||||
(unless (set? set) (raise-argument-error 'set-member? "set?" 0 set v))
|
||||
(hash-ref (set-ht set) v #f))
|
||||
|
||||
(define (set-add set v)
|
||||
(unless (set? set) (raise-argument-error 'set-add "set?" 0 set v))
|
||||
(make-set (hash-set (set-ht set) v #t)))
|
||||
|
||||
(define (set-remove set v)
|
||||
(unless (set? set) (raise-argument-error 'set-remove "set?" 0 set v))
|
||||
(make-set (hash-remove (set-ht set) v)))
|
||||
|
||||
(define (check-same-equiv who set set2 ht ht2)
|
||||
(unless (and (eq? (hash-eq? ht) (hash-eq? ht2))
|
||||
(eq? (hash-eqv? ht) (hash-eqv? ht2)))
|
||||
(raise-arguments-error who
|
||||
"second set's equivalence predicate is not the same as the first set's"
|
||||
"first set" set
|
||||
"second set" set2)))
|
||||
|
||||
(define set-union
|
||||
(case-lambda
|
||||
;; No 0 argument set exists because its not clear what type of set
|
||||
;; to return. A keyword is unsatisfactory because it may be hard to
|
||||
;; remember. A simple solution is just to provide the type of the
|
||||
;; empty set that you want, like (set-union (set)) or
|
||||
;; (set-union (set-eqv))
|
||||
;; [() (set)]
|
||||
[(set)
|
||||
(unless (set? set) (raise-argument-error 'set-union "set?" 0 set))
|
||||
set]
|
||||
[(set set2)
|
||||
(unless (set? set) (raise-argument-error 'set-union "set?" 0 set set2))
|
||||
(unless (set? set2) (raise-argument-error 'set-union "set?" 1 set set2))
|
||||
(let ([ht (set-ht set)]
|
||||
[ht2 (set-ht set2)])
|
||||
(check-same-equiv 'set-union set set2 ht ht2)
|
||||
(let-values ([(ht ht2)
|
||||
(if ((hash-count ht2) . > . (hash-count ht))
|
||||
(values ht2 ht)
|
||||
(values ht ht2))])
|
||||
(make-set
|
||||
(for/fold ([ht ht]) ([v (in-hash-keys ht2)])
|
||||
(hash-set ht v #t)))))]
|
||||
[(set . sets)
|
||||
(for ([s (in-list (cons set sets))]
|
||||
[i (in-naturals)])
|
||||
(unless (set? s) (apply raise-argument-error 'set-union "set?" i (cons set sets))))
|
||||
(for/fold ([set set]) ([set2 (in-list sets)])
|
||||
(set-union set set2))]))
|
||||
|
||||
(define (empty-like ht)
|
||||
(cond
|
||||
[(hash-eqv? ht) #hasheqv()]
|
||||
[(hash-eq? ht) #hasheq()]
|
||||
[else #hash()]))
|
||||
|
||||
(define set-intersect
|
||||
(case-lambda
|
||||
[(set)
|
||||
(unless (set? set) (raise-argument-error 'set-intersect "set?" 0 set))
|
||||
set]
|
||||
[(set set2)
|
||||
(unless (set? set) (raise-argument-error 'set-intersect "set?" 0 set set2))
|
||||
(unless (set? set2) (raise-argument-error 'set-intersect "set?" 1 set set2))
|
||||
(let ([ht1 (set-ht set)]
|
||||
[ht2 (set-ht set2)])
|
||||
(check-same-equiv 'set-intersect set set2 ht1 ht2)
|
||||
(let-values ([(ht1 ht2) (if ((hash-count ht1) . < . (hash-count ht2))
|
||||
(values ht1 ht2)
|
||||
(values ht2 ht1))])
|
||||
(make-set
|
||||
(for/fold ([ht (empty-like (set-ht set))]) ([v (in-hash-keys ht1)])
|
||||
(if (hash-ref ht2 v #f)
|
||||
(hash-set ht v #t)
|
||||
ht)))))]
|
||||
[(set . sets)
|
||||
(for ([s (in-list (cons set sets))]
|
||||
[i (in-naturals)])
|
||||
(unless (set? s) (apply raise-argument-error 'set-intersect "set?" i (cons set sets))))
|
||||
(for/fold ([set set]) ([set2 (in-list sets)])
|
||||
(set-intersect set set2))]))
|
||||
|
||||
(define set-subtract
|
||||
(case-lambda
|
||||
[(set)
|
||||
(unless (set? set) (raise-argument-error 'set-subtract "set?" 0 set))
|
||||
set]
|
||||
[(set set2)
|
||||
(unless (set? set) (raise-argument-error 'set-subtract "set?" 0 set set2))
|
||||
(unless (set? set2) (raise-argument-error 'set-subtract "set?" 1 set set2))
|
||||
(let ([ht1 (set-ht set)]
|
||||
[ht2 (set-ht set2)])
|
||||
(check-same-equiv 'set-subtract set set2 ht1 ht2)
|
||||
(if ((* 2 (hash-count ht1)) . < . (hash-count ht2))
|
||||
;; Add elements from ht1 that are not in ht2:
|
||||
(make-set
|
||||
(for/fold ([ht (empty-like ht1)]) ([v (in-hash-keys ht1)])
|
||||
(if (hash-ref ht2 v #f)
|
||||
ht
|
||||
(hash-set ht v #t))))
|
||||
;; Remove elements from ht1 that are in ht2
|
||||
(make-set
|
||||
(for/fold ([ht ht1]) ([v (in-hash-keys ht2)])
|
||||
(hash-remove ht v)))))]
|
||||
[(set . sets)
|
||||
(for ([s (in-list (cons set sets))]
|
||||
[i (in-naturals)])
|
||||
(unless (set? s) (apply raise-argument-error 'set-subtract "set?" i (cons s sets))))
|
||||
(for/fold ([set set]) ([set2 (in-list sets)])
|
||||
(set-subtract set set2))]))
|
||||
|
||||
(define (subset* who set2 set1 proper?)
|
||||
(unless (set? set2) (raise-argument-error who "set?" 0 set2 set1))
|
||||
(unless (set? set1) (raise-argument-error who "set?" 0 set2 set1))
|
||||
(let ([ht1 (set-ht set1)]
|
||||
[ht2 (set-ht set2)])
|
||||
(check-same-equiv who set set2 ht1 ht2)
|
||||
(and (for/and ([v (in-hash-keys ht2)])
|
||||
(hash-ref ht1 v #f))
|
||||
(if proper?
|
||||
(< (hash-count ht2) (hash-count ht1))
|
||||
#t))))
|
||||
|
||||
(define (subset? one two)
|
||||
(subset* 'subset? one two #f))
|
||||
|
||||
(define (proper-subset? one two)
|
||||
(subset* 'proper-subset? one two #t))
|
||||
|
||||
(define (set-first set)
|
||||
(unless (set? set) (raise-argument-error 'set-first "set?" set))
|
||||
(define ht (set-ht set))
|
||||
(if (zero? (hash-count ht))
|
||||
(raise-arguments-error 'set-first "given set is empty")
|
||||
(hash-iterate-key ht (hash-iterate-first ht))))
|
||||
|
||||
(define (set-rest set)
|
||||
(unless (set? set) (raise-argument-error 'set-rest "set?" set))
|
||||
(define ht (set-ht set))
|
||||
(if (zero? (hash-count ht))
|
||||
(raise-arguments-error 'set-rest "given set is empty")
|
||||
(make-set (hash-remove ht (hash-iterate-key ht (hash-iterate-first ht))))))
|
||||
|
||||
(define (set-map set proc)
|
||||
(unless (set? set) (raise-argument-error 'set-map "set?" 0 set proc))
|
||||
(unless (and (procedure? proc)
|
||||
(procedure-arity-includes? proc 1))
|
||||
(raise-argument-error 'set-map "(any/c . -> . any/c)" 1 set proc))
|
||||
(for/list ([v (in-set set)])
|
||||
(proc v)))
|
||||
|
||||
(define (set-for-each set proc)
|
||||
(unless (set? set) (raise-argument-error 'set-for-each "set?" 0 set proc))
|
||||
(unless (and (procedure? proc)
|
||||
(procedure-arity-includes? proc 1))
|
||||
(raise-argument-error 'set-for-each "(any/c . -> . any/c)" 1 set proc))
|
||||
(for ([v (in-set set)])
|
||||
(proc v)))
|
||||
|
||||
(define (in-set set)
|
||||
(unless (set? set) (raise-argument-error 'in-set "set?" 0 set))
|
||||
(in-hash-keys (set-ht set)))
|
||||
|
||||
(define-sequence-syntax *in-set
|
||||
(lambda () #'in-set)
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set)
|
||||
;; Set construction is costly, so specialize empty/singleton cases
|
||||
[[(id) (_ (set))] #'[(id) (:do-in ([(id) #f]) #t () #f () #f #f ())]]
|
||||
[[(id) (_ (set expr))] #'[(id) (:do-in ([(id) expr]) #t () #t () #t #f ())]]
|
||||
[[(id) (_ st)]
|
||||
#`[(id)
|
||||
(:do-in
|
||||
;; outer bindings:
|
||||
([(ht) (let ([s st]) (if (set? s) (set-ht s) (list s)))])
|
||||
;; outer check:
|
||||
(unless (hash? ht)
|
||||
;; let `in-set' report the error:
|
||||
(in-set (car ht)))
|
||||
;; loop bindings:
|
||||
([pos (hash-iterate-first ht)])
|
||||
;; pos check
|
||||
pos
|
||||
;; inner bindings
|
||||
([(id) (hash-iterate-key ht pos)])
|
||||
;; pre guard
|
||||
#t
|
||||
;; post guard
|
||||
#t
|
||||
;; loop args
|
||||
((hash-iterate-next ht pos)))]])))
|
||||
|
||||
(define-syntax-rule (define-for for/fold/derived for/set set)
|
||||
(define-syntax (for/set stx)
|
||||
(...
|
||||
(syntax-case stx ()
|
||||
[(_ bindings . body)
|
||||
(with-syntax ([((pre-body ...) post-body) (split-for-body stx #'body)])
|
||||
(quasisyntax/loc stx
|
||||
(for/fold/derived #,stx ([s (set)]) bindings pre-body ... (set-add s (let () . post-body)))))]))))
|
||||
|
||||
(define-for for/fold/derived for/set set)
|
||||
(define-for for*/fold/derived for*/set set)
|
||||
(define-for for/fold/derived for/seteq seteq)
|
||||
(define-for for*/fold/derived for*/seteq seteq)
|
||||
(define-for for/fold/derived for/seteqv seteqv)
|
||||
(define-for for*/fold/derived for*/seteqv seteqv)
|
||||
|
||||
(define (get-pred a-set/c)
|
||||
(case (set/c-cmp a-set/c)
|
||||
[(dont-care) set?]
|
||||
[(eq) set-eq?]
|
||||
[(eqv) set-eqv?]
|
||||
[(equal) set-equal?]))
|
||||
|
||||
(define (get-name a-set/c)
|
||||
(case (set/c-cmp a-set/c)
|
||||
[(dont-care) 'set]
|
||||
[(eq) 'set-eq]
|
||||
[(eqv) 'set-eqv]
|
||||
[(equal) 'set-equal]))
|
||||
|
||||
(define *set/c
|
||||
(let ()
|
||||
(define (set/c ctc #:cmp [cmp 'dont-care])
|
||||
(unless (memq cmp '(dont-care equal eq eqv))
|
||||
(raise-argument-error 'set/c
|
||||
"(or/c 'dont-care 'equal? 'eq? 'eqv)"
|
||||
cmp))
|
||||
(cond
|
||||
[(flat-contract? ctc)
|
||||
(flat-set/c ctc cmp (flat-contract-predicate ctc))]
|
||||
[(chaperone-contract? ctc)
|
||||
(if (memq cmp '(eq eqv))
|
||||
(raise-argument-error 'set/c
|
||||
"flat-contract?"
|
||||
ctc)
|
||||
(make-set/c ctc cmp))]
|
||||
[else
|
||||
(raise-argument-error 'set/c
|
||||
"chaperone-contract?"
|
||||
ctc)]))
|
||||
set/c))
|
||||
|
||||
(define (set/c-name c)
|
||||
`(set/c ,(contract-name (set/c-ctc c))
|
||||
,@(if (eq? (set/c-cmp c) 'dont-care)
|
||||
'()
|
||||
`(#:cmp ',(set/c-cmp c)))))
|
||||
|
||||
(define (set/c-stronger this that)
|
||||
(and (set/c? that)
|
||||
(or (eq? (set/c-cmp this)
|
||||
(set/c-cmp that))
|
||||
(eq? (set/c-cmp that) 'dont-care))
|
||||
(contract-stronger? (set/c-ctc this)
|
||||
(set/c-ctc that))))
|
||||
|
||||
(define (check-set/c ctc)
|
||||
(let ([elem-ctc (set/c-ctc ctc)]
|
||||
[pred (get-pred ctc)]
|
||||
[name (get-name ctc)])
|
||||
(λ (val fail [first-order? #f])
|
||||
(unless (pred val)
|
||||
(fail '(expected: "~a" given: "~e") name val))
|
||||
(when first-order?
|
||||
(for ([e (in-set val)])
|
||||
(unless (contract-first-order-passes? elem-ctc e)
|
||||
(fail '(expected: "~a" given: "~e") (contract-name elem-ctc) e))))
|
||||
#t)))
|
||||
|
||||
(define (set/c-first-order ctc)
|
||||
(let ([check (check-set/c ctc)])
|
||||
(λ (val)
|
||||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
|
||||
(define (set/c-proj c)
|
||||
(let ([proj (contract-projection (set/c-ctc c))]
|
||||
[check (check-set/c c)])
|
||||
(λ (blame)
|
||||
(let ([pb (proj blame)])
|
||||
(λ (s)
|
||||
(check s (λ args (apply raise-blame-error blame s args)))
|
||||
(chaperone-set s (λ (s v) (pb v))))))))
|
||||
|
||||
(define-struct set/c (ctc cmp)
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name set/c-name
|
||||
#:first-order set/c-first-order
|
||||
#:stronger set/c-stronger
|
||||
#:projection set/c-proj))
|
||||
|
||||
(define (flat-set/c-proj c)
|
||||
(let ([proj (contract-projection (set/c-ctc c))]
|
||||
[check (check-set/c c)])
|
||||
(λ (blame)
|
||||
(let ([pb (proj blame)])
|
||||
(λ (val)
|
||||
(check val (λ args (apply raise-blame-error blame val args)))
|
||||
(for ([e (in-set val)]) (pb e))
|
||||
val)))))
|
||||
|
||||
(define-values (flat-set/c flat-set/c-pred)
|
||||
(let ()
|
||||
(define-struct (flat-set/c set/c) (pred)
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name set/c-name
|
||||
#:first-order set/c-first-order
|
||||
#:stronger set/c-stronger
|
||||
#:projection flat-set/c-proj))
|
||||
(values make-flat-set/c flat-set/c-pred)))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (set=? one two)
|
||||
(unless (set? one) (raise-argument-error 'set=? "set?" 0 one two))
|
||||
(unless (set? two) (raise-argument-error 'set=? "set?" 1 one two))
|
||||
;; Sets implement prop:equal+hash
|
||||
(equal? one two))
|
||||
|
||||
(define set-symmetric-difference
|
||||
(case-lambda
|
||||
[(set)
|
||||
(unless (set? set) (raise-argument-error 'set-symmetric-difference "set?" 0 set))
|
||||
set]
|
||||
[(set set2)
|
||||
(unless (set? set) (raise-argument-error 'set-symmetric-difference "set?" 0 set set2))
|
||||
(unless (set? set2) (raise-argument-error 'set-symmetric-difference "set?" 1 set set2))
|
||||
(let ([ht1 (set-ht set)]
|
||||
[ht2 (set-ht set2)])
|
||||
(check-same-equiv 'set-symmetric-difference set set2 ht1 ht2)
|
||||
(let-values ([(big small)
|
||||
(if (>= (hash-count ht1) (hash-count ht2))
|
||||
(values ht1 ht2)
|
||||
(values ht2 ht1))])
|
||||
(make-set
|
||||
(for/fold ([ht big]) ([e (in-hash-keys small)])
|
||||
(if (hash-ref ht e #f)
|
||||
(hash-remove ht e)
|
||||
(hash-set ht e #t))))))]
|
||||
[(set . sets)
|
||||
(for ([s (in-list (cons set sets))]
|
||||
[i (in-naturals)])
|
||||
(unless (set? s) (apply raise-argument-error 'set-symmetric-difference "set?" i (cons s sets))))
|
||||
(for/fold ([set set]) ([set2 (in-list sets)])
|
||||
(set-symmetric-difference set set2))]))
|
||||
|
||||
(define (set->list set)
|
||||
(unless (set? set) (raise-argument-error 'set->list "set?" 0 set))
|
||||
(for/list ([elem (in-hash-keys (set-ht set))]) elem))
|
||||
(define (list->set elems)
|
||||
(unless (list? elems) (raise-argument-error 'list->set "list?" 0 elems))
|
||||
(apply set elems))
|
||||
(define (list->seteq elems)
|
||||
(unless (list? elems) (raise-argument-error 'list->seteq "list?" 0 elems))
|
||||
(apply seteq elems))
|
||||
(define (list->seteqv elems)
|
||||
(unless (list? elems) (raise-argument-error 'list->seteqv "list?" 0 elems))
|
||||
(apply seteqv elems))
|
||||
[(flat-contract? c) make-flat-contract]
|
||||
[(chaperone-contract? c) make-chaperone-contract]
|
||||
[else make-contract]))
|
||||
(make
|
||||
#:name name
|
||||
#:first-order (contract-first-order c)
|
||||
#:projection
|
||||
(lambda (b)
|
||||
((contract-projection c)
|
||||
(blame-add-context b #f)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user