basic set library

svn: r18222
This commit is contained in:
Matthew Flatt 2010-02-20 13:00:48 +00:00
parent d2bdc2eca8
commit e38e8d88e0
7 changed files with 426 additions and 2 deletions

196
collects/scheme/set.ss Normal file
View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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