basic set library
svn: r18222
This commit is contained in:
parent
d2bdc2eca8
commit
e38e8d88e0
196
collects/scheme/set.ss
Normal file
196
collects/scheme/set.ss
Normal 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)))]])))
|
|
@ -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"]
|
||||
|
||||
|
|
|
@ -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)
|
||||
]}
|
||||
|
|
118
collects/scribblings/reference/sets.scrbl
Normal file
118
collects/scribblings/reference/sets.scrbl
Normal 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.}
|
|
@ -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?]{
|
||||
|
||||
|
|
|
@ -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")
|
||||
|
|
105
collects/tests/mzscheme/set.ss
Normal file
105
collects/tests/mzscheme/set.ss
Normal 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)
|
Loading…
Reference in New Issue
Block a user