From a651591a1529b1be33729968f2557bb452a22560 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 21 Jul 2013 16:29:10 -0400 Subject: [PATCH] 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. --- racket/collects/racket/private/set-types.rkt | 849 +++++++++++++++++++ racket/collects/racket/private/set.rkt | 532 ++++++++++++ racket/collects/racket/set.rkt | 569 ++----------- 3 files changed, 1448 insertions(+), 502 deletions(-) create mode 100644 racket/collects/racket/private/set-types.rkt create mode 100644 racket/collects/racket/private/set.rkt diff --git a/racket/collects/racket/private/set-types.rkt b/racket/collects/racket/private/set-types.rkt new file mode 100644 index 0000000000..9af7f16ec5 --- /dev/null +++ b/racket/collects/racket/private/set-types.rkt @@ -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)) diff --git a/racket/collects/racket/private/set.rkt b/racket/collects/racket/private/set.rkt new file mode 100644 index 0000000000..fbaa4c7a1b --- /dev/null +++ b/racket/collects/racket/private/set.rkt @@ -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!)]) diff --git a/racket/collects/racket/set.rkt b/racket/collects/racket/set.rkt index b0d7cc6a5f..6b6eae0eff 100644 --- a/racket/collects/racket/set.rkt +++ b/racket/collects/racket/set.rkt @@ -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 "#" 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)))))