diff --git a/collects/scheme/set.ss b/collects/scheme/set.ss new file mode 100644 index 0000000000..2056adb58c --- /dev/null +++ b/collects/scheme/set.ss @@ -0,0 +1,196 @@ +#lang scheme/base +(require (for-syntax scheme/base)) + +(provide (rename-out [make-set* make-set]) + make-seteq make-seteqv + set? set-eq? set-eqv? + set-empty? set-count + set-member? set-add set-remove + set-union set-intersect set-subtract + set-map set-for-each + (rename-out [*in-set in-set])) + +(define-struct set (ht) + #: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))) + +(define make-set* + (let ([make-set (lambda elems + (make-set (make-immutable-hash (map (lambda (k) (cons k #t)) elems))))]) + make-set)) +(define (make-seteq . elems) + (make-set (make-immutable-hasheq (map (lambda (k) (cons k #t)) elems)))) +(define (make-seteqv . elems) + (make-set (make-immutable-hasheqv (map (lambda (k) (cons k #t)) elems)))) + +(define (set-eq? set) + (unless (set? set) (raise-type-error 'set-eq? "set" 0 set)) + (hash-eq? (set-ht set))) +(define (set-eqv? set) + (unless (set? set) (raise-type-error 'set-eqv? "set" 0 set)) + (hash-eqv? (set-ht set))) + +(define (set-empty? set) + (unless (set? set) (raise-type-error 'set-empty? "set" 0 set)) + (zero? (hash-count (set-ht set)))) + +(define (set-count set) + (unless (set? set) (raise-type-error 'set-count "set" 0 set)) + (hash-count (set-ht set))) + +(define (set-member? set v) + (unless (set? set) (raise-type-error 'set-member? "set" 0 set v)) + (hash-ref (set-ht set) v #f)) + +(define (set-add set v) + (unless (set? set) (raise-type-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-type-error 'set-remove "set" 0 set v)) + (make-set (hash-remove (set-ht set) v))) + +(define set-union + (case-lambda + [(set) + (unless (set? set) (raise-type-error 'set-union "set" 0 set)) + set] + [(set set2) + (unless (set? set) (raise-type-error 'set-union "set" 0 set set2)) + (unless (set? set2) (raise-type-error 'set-union "set" 1 set set2)) + (let ([ht (set-ht set)] + [ht2 (set-ht set2)]) + (unless (and (eq? (hash-eq? ht) (hash-eq? ht2)) + (eq? (hash-eqv? ht) (hash-eqv? ht2))) + (raise-mismatch-error 'set-union "set's equivalence predicate is not the same as the first set: " + set2)) + (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-type-error 'set-union "set" i 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-type-error 'set-intersect "set" 0 set)) + set] + [(set set2) + (unless (set? set) (raise-type-error 'set-intersect "set" 0 set set2)) + (unless (set? set2) (raise-type-error 'set-intersect "set" 1 set set2)) + (let ([ht1 (set-ht set)] + [ht2 (set-ht set2)]) + (unless (and (eq? (hash-eq? ht1) (hash-eq? ht2)) + (eq? (hash-eqv? ht1) (hash-eqv? ht2))) + (raise-mismatch-error 'set-union "set's equivalence predicate is not the same as the first set: " + set2)) + (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-type-error 'set-intersect "set" i sets))) + (for/fold ([set set]) ([set2 (in-list sets)]) + (set-intersect set set2))])) + +(define set-subtract + (case-lambda + [(set) + (unless (set? set) (raise-type-error 'set-subtract "set" 0 set)) + set] + [(set set2) + (unless (set? set) (raise-type-error 'set-subtract "set" 0 set set2)) + (unless (set? set2) (raise-type-error 'set-subtract "set" 1 set set2)) + (let ([ht1 (set-ht set)] + [ht2 (set-ht set2)]) + (unless (and (eq? (hash-eq? ht1) (hash-eq? ht2)) + (eq? (hash-eqv? ht1) (hash-eqv? ht2))) + (raise-mismatch-error 'set-union "set's equivalence predicate is not the same as the first set: " + set2)) + (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-type-error 'set-subtract "set" i sets))) + (for/fold ([set set]) ([set2 (in-list sets)]) + (set-subtract set set2))])) + +(define (set-map set proc) + (unless (set? set) (raise-type-error 'set-map "set" 0 set proc)) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 1)) + (raise-type-error 'set-map "procedure (arity 1)" 1 set proc)) + (for/list ([v (in-set set)]) + (proc v))) + +(define (set-for-each set proc) + (unless (set? set) (raise-type-error 'set-for-each "set" 0 set proc)) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 1)) + (raise-type-error 'set-for-each "procedure (arity 1)" 1 set proc)) + (for ([v (in-set set)]) + (proc v))) + +(define (in-set set) + (unless (set? set) (raise-type-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 () + [[(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)))]]))) diff --git a/collects/scribblings/reference/data.scrbl b/collects/scribblings/reference/data.scrbl index 1a06144792..25dd6272c2 100644 --- a/collects/scribblings/reference/data.scrbl +++ b/collects/scribblings/reference/data.scrbl @@ -215,6 +215,9 @@ Sets the content of @scheme[box] to @scheme[v].} @; ---------------------------------------------------------------------- @include-section["dicts.scrbl"] +@; ---------------------------------------------------------------------- +@include-section["sets.scrbl"] + @; ---------------------------------------------------------------------- @include-section["procedures.scrbl"] diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index f75567b0c1..d9a9f243c3 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -444,7 +444,8 @@ of the generator. (define introspective-generator (generator ((yield 1)))) (introspective-generator) -(introspective-generator (lambda () (generator-state introspective-generator))) +(introspective-generator + (lambda () (generator-state introspective-generator))) (generator-state introspective-generator) (introspective-generator) ]} diff --git a/collects/scribblings/reference/sets.scrbl b/collects/scribblings/reference/sets.scrbl new file mode 100644 index 0000000000..a1e790fb98 --- /dev/null +++ b/collects/scribblings/reference/sets.scrbl @@ -0,0 +1,118 @@ +#lang scribble/doc +@(require "mz.ss" + (for-label scheme/set)) + +@title[#:tag "sets"]{Sets} + +@(define (mutable-key-caveat) + @elemref['(caveat "mutable-keys")]{caveat concerning mutable keys}) + +A @deftech{set} represents a set of distinct elements. For a given +set, elements are equivalent via @scheme[equal?], @scheme[eqv?], or +@scheme[eq?]. Two sets are @scheme[equal?] they use the same +key-comparison procedure (@scheme[equal?], @scheme[eqv?], or +@scheme[eq?]) and have equivalent elements. A set can be used as a +@tech{sequence} (see @secref["sequences"]). + +For sets that contain elements that are mutated, then operations on +the set become unpredictable in much the same way that @tech{hash +table} operations are unpredictable when keys are mutated. + +@note-lib-only[scheme/set] + +@defproc[(set? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is a @tech{set}, @scheme[#f] +otherwise.} + +@defproc[(set-eqv? [set set?]) boolean?]{ + +Returns @scheme[#t] if @scheme[set] compares elements with @scheme[eqv?], +@scheme[#f] if it compares with @scheme[equal?] or @scheme[eq?].} + +@defproc[(set-eq? [set set?]) boolean?]{ + +Returns @scheme[#t] if @scheme[set] compares elements with @scheme[eq?], +@scheme[#f] if it compares with @scheme[equal?] or @scheme[eqv?].} + +@deftogether[( +@defproc[(make-set [v any/c] ...) set?] +@defproc[(make-seteqv [v any/c] ...) set?] +@defproc[(make-seteq [v any/c] ...) set?] +)]{ + +Creates a set that uses @scheme[equal?], @scheme[eq?], or +@scheme[eqv?], respectively, to compare elements. The given +@scheme[v]s are added to the set. The elements are added in the order +that they appear as @scheme[v]s, so in the first two cases, an earlier +element that is @scheme[equal?] or @scheme[eqv?] but not @scheme[eq?] +to a later element takes precedence over the later element.} + +@defproc[(set-member? [set set?] [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is in @scheme[set], @scheme[#f] +otherwise.} + +@defproc[(set-add [set set?] [v any/c]) set?]{ + +@margin-note{Like operations on immutable hash tables, ``constant +time'' set operations actually require @math{O(log N)} time for a set +of size @math{N}.} + +Produces a set that includes @scheme[v] plus all elements of of +@scheme[set]. This operation runs constant time.} + + +@defproc[(set-remove [set set?] [v any/c]) set?]{ + +Produces a set that includes all elements of @scheme[set] except +@scheme[v]. This operation runs in constant time.} + + +@defproc[(set-union [set set?] ...+) set?]{ + +Produces a set that includes all elements of all given @scheme[set]s, +which must all use the same equivalence predicate (@scheme[equal?], +@scheme[eq?], or @scheme[eqv?]). This operation runs in time +proportional to the total size of all given @scheme[set]s except for +the largest.} + + +@defproc[(set-intersect [set set?] ...+) set?]{ + +Produces a set that includes only the elements in all of the given +@scheme[set]s, which must all use the same equivalence predicate +(@scheme[equal?], @scheme[eq?], or @scheme[eqv?]). This operation +runs in time proportional to the total size of all given +@scheme[set]s except for the largest.} + + +@defproc[(set-subtract [set set?] ...+) set?]{ + +Produces a set that includes all elements the first @scheme[set]s that +are not present in any of the other given @scheme[sets]s. All of the +given @scheme[set]s must use the same equivalence predicate +(@scheme[equal?], @scheme[eq?], or @scheme[eqv?]). This operation +runs in time proportional to the total size of all given +@scheme[set]s except the first one.} + + +@defproc[(set-map [set set?] + [proc (any/c . -> . any/c)]) + (listof any/c)]{ + +Applies the procedure @scheme[proc] to each element in +@scheme[set] in an unspecified order, accumulating the results +into a list.} + +@defproc[(set-for-each [set set?] + [proc (any/c . -> . any)]) + void?]{ + +Applies @scheme[proc] to each element in @scheme[set] (for the +side-effects of @scheme[proc]) in an unspecified order.} + +@defproc[(in-set [set set?]) sequence?]{ + +Explicitly converts a set to a sequence for use with @scheme[for] and +other forms.} diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl index 9a75a27980..9e7694df2b 100644 --- a/collects/scribblings/reference/time.scrbl +++ b/collects/scribblings/reference/time.scrbl @@ -123,7 +123,7 @@ result is the result of @scheme[expr].} @section[#:tag "date-string"]{Date Utilities} -@defmodule[scheme/date] +@note-lib-only[scheme/date] @defproc[(date->string [date date?][time? any/c #f]) string?]{ diff --git a/collects/tests/mzscheme/mzlib-tests.ss b/collects/tests/mzscheme/mzlib-tests.ss index 99a1f257ad..348484968b 100644 --- a/collects/tests/mzscheme/mzlib-tests.ss +++ b/collects/tests/mzscheme/mzlib-tests.ss @@ -13,6 +13,7 @@ (load-in-sandbox "filelib.ss") (load-in-sandbox "portlib.ss") (load-in-sandbox "threadlib.ss") +(load-in-sandbox "set.ss") (load-in-sandbox "date.ss") (load-in-sandbox "compat.ss") (load-in-sandbox "cmdline.ss") diff --git a/collects/tests/mzscheme/set.ss b/collects/tests/mzscheme/set.ss new file mode 100644 index 0000000000..631a8b0af4 --- /dev/null +++ b/collects/tests/mzscheme/set.ss @@ -0,0 +1,105 @@ +(load-relative "loadtest.ss") + +(Section 'sets) +(require scheme/set) + +;; ---------------------------------------- + +(test #t set? (make-set)) +(test #t set-empty? (make-set)) +(test #t set? (make-set 1 2 3)) +(test #f set-empty? (make-set 1 2 3)) +(test #t set? (make-seteq)) +(test #t set-empty? (make-seteq)) +(test #t set? (make-seteq 1 2 3)) +(test #f set-empty? (make-seteq 1 2 3)) +(test #t set? (make-seteqv)) +(test #t set-empty? (make-seteqv)) +(test #t set? (make-seteqv 1 2 3)) +(test #f set-empty? (make-seteqv 1 2 3)) + +(test #f set-eq? (make-set 1 2 3)) +(test #f set-eqv? (make-set 1 2 3)) +(test #t set-eq? (make-seteq 1 2 3)) +(test #f set-eqv? (make-seteq 1 2 3)) +(test #f set-eq? (make-seteqv 1 2 3)) +(test #t set-eqv? (make-seteqv 1 2 3)) + +(test 3 set-count (make-set (string #\a) "b" "c" (string #\a))) +(test 4 set-count (make-seteqv (string #\a) "b" "c" (string #\a))) +(test 4 set-count (make-seteq (string #\a) "b" "c" (string #\a))) + +(test #t set-member? (make-set 1 2 3) 1) +(test #t set-member? (make-set 1 2 3) 2) +(test #t set-member? (make-set 1 2 3) 3) +(test #f set-member? (make-set 1 2 3) 4) + +(let ([s (make-set 1 2 3)]) + (test #t equal? s (set-add (set-add (set-add (make-set) 1) 2) 3)) + (test #t equal? (make-seteq 1 2 3) (make-seteq 1 2 3)) + (test #t equal? (make-seteq 1 2 3) (make-seteq 3 2 1)) + (test #t equal? (make-seteqv 1 2 3) (make-seteqv 1 2 3)) + (test #f equal? s (make-seteq 1 2 3)) + (test #f equal? s (make-seteqv 1 2 3)) + (test #f equal? (make-seteq 1 2 3) (make-seteqv 1 2 3)) + + (test #t set-member? (set-add s 5) 3) + (test #t set-member? (set-add s 5) 5) + (test #f set-member? (set-add s 5) 4) + + (test #t set-member? (set-remove s 5) 3) + (test #f set-member? (set-remove s 3) 3) + + (test 3 set-count (set-union s)) + (test 6 set-count (set-union s (make-set 3 4 5 6))) + (test 6 set-count (set-union (make-set 3 4 5 6) s)) + (test 8 set-count (set-union (make-set 3 4 5 6) s (make-set 1 10 100))) + + (test (make-seteq 1 2 3) set-union (make-seteq 1 2) (make-seteq 3)) + (test (make-seteqv 1 2 3) set-union (make-seteqv 1 2) (make-seteqv 3)) + + (test s set-intersect s) + (test (make-set 3) set-intersect s (make-set 5 4 3 6)) + (test (make-set 3) set-intersect (make-set 5 4 3 6) s) + (test (make-seteq 3) set-intersect (make-seteq 5 4 3 6) (make-seteq 1 2 3)) + (test (make-seteqv 3) set-intersect (make-seteqv 5 4 3 6) (make-seteqv 1 2 3)) + (test (make-set 3 2) set-intersect s (make-set 5 2 3)) + (test (make-seteq 3 2) set-intersect (make-seteq 1 2 3) (make-seteq 5 2 3)) + (test (make-set 2) set-intersect s (make-set 5 2 3) (make-set 2 20 200)) + (test (make-seteq 2) set-intersect (make-seteq 1 2 3) (make-seteq 5 2 3) (make-seteq 2 20 200)) + + (test s set-subtract s) + (test (make-set) set-subtract s s) + (test s set-subtract s (make-set 100)) + (test (make-set 1 3) set-subtract s (make-set 2 100)) + (test (make-seteq 100) set-subtract (make-seteq 2 100) (make-seteq 1 2 3)) + (test (make-seteq 9 100) set-subtract (make-seteq 2 100 1000 9) (make-seteq 1 2 3) (make-seteq 1000 5)) + + (let ([try-mismatch (lambda (set-op) + (err/rt-test (set-op (make-seteqv 1 2) (make-set 3))) + (err/rt-test (set-op (make-seteqv 1 2) (make-seteq 3))) + (err/rt-test (set-op (make-set 1 2) (make-seteq 3))) + (err/rt-test (set-op (make-set 1 2) (make-set 4) (make-seteq 3))) + (err/rt-test (set-op (make-set 1 2) (make-seteq 3) (make-set 4))) + (err/rt-test (set-op (make-seteq 3) (make-set 1 2) (make-set 4))))]) + (try-mismatch set-union) + (try-mismatch set-intersect) + (try-mismatch set-subtract)) + + (test #t andmap negative? (set-map s -)) + (test 3 length (set-map s +)) + + (let ([v 0]) + (set-for-each s (lambda (n) (set! v (+ v n)))) + (test 6 values v)) + + (test '(1 2 3) sort (for/list ([v s]) v) <) + (test '(1 2 3) sort (for/list ([v (in-set s)]) v) <) + (test '(1 2 3) sort (let ([seq (in-set s)]) (for/list ([v seq]) v)) <) + + + (void)) + +;; ---------------------------------------- + +(report-errs)