basic set library

svn: r18222

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)))]])))

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"]
 

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)
 ]}

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.}

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?]{
 

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")

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)