Sync up to trunk, because keeping up to date is the right thing to do (and
hopefully it'll get rid of the issues in tests/future/future.ss). svn: r18228
This commit is contained in:
Stevie Strickland
commit
a169105ed0
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"]
|
||||
|
||||
|
|
|
|||
|
|
@ -586,8 +586,12 @@ produces @scheme[+nan.0] in the case that neither @scheme[y] nor
|
|||
@defproc[(bitwise-bit-set? [n exact-integer?] [m exact-nonnegative-integer?])
|
||||
boolean?]{
|
||||
|
||||
Returns @scheme[(not (zero? (bitwise-and n (arithmetic-shift 1 m))))],
|
||||
but faster and in constant time when @scheme[n] is positive.
|
||||
Returns @scheme[#t] when the @scheme[m]th bit of @scheme[n] is set in @scheme[n]'s
|
||||
(semi-infinite) two's complement representation.
|
||||
|
||||
This is equivalent to
|
||||
@scheme[(not (zero? (bitwise-and n (arithmetic-shift 1 m))))],
|
||||
but is faster and runs in constant time when @scheme[n] is positive.
|
||||
|
||||
@mz-examples[(bitwise-bit-set? 5 0) (bitwise-bit-set? 5 2) (bitwise-bit-set? -5 (expt 2 700))]}
|
||||
|
||||
|
|
@ -596,22 +600,32 @@ but faster and in constant time when @scheme[n] is positive.
|
|||
[start exact-nonnegative-integer?]
|
||||
[end (and/c exact-nonnegative-integer?
|
||||
(start . <= . end))])
|
||||
boolean?]{
|
||||
exact-integer?]{
|
||||
|
||||
Returns
|
||||
Extracts the bits between position @scheme[start] and @scheme[(- end 1)] (inclusive)
|
||||
from @scheme[n] and shifts them down to the least significant portion of the number.
|
||||
|
||||
This is equivalent to this computation,
|
||||
|
||||
@schemeblock[
|
||||
(bitwise-and (sub1 (arithmetic-shift 1 (- end start)))
|
||||
(arithmetic-shift n (- start)))
|
||||
]
|
||||
|
||||
but in constant time when @scheme[n] is positive, @scheme[start] and
|
||||
but it runs in constant time when @scheme[n] is positive, @scheme[start] and
|
||||
@scheme[end] are fixnums, and @scheme[(- end start)] is no more than
|
||||
the maximum width of a fixnum.
|
||||
|
||||
@mz-examples[(bitwise-bit-field 13 1 1)
|
||||
Each pair of examples below uses the same numbers, but shows the result in
|
||||
both binary and as integers.
|
||||
|
||||
@mz-examples[(format "~b" (bitwise-bit-field (string->number "1101" 2) 1 1))
|
||||
(bitwise-bit-field 13 1 1)
|
||||
(format "~b" (bitwise-bit-field (string->number "1101" 2) 1 3))
|
||||
(bitwise-bit-field 13 1 3)
|
||||
(bitwise-bit-field 13 1 4)]}
|
||||
(format "~b" (bitwise-bit-field (string->number "1101" 2) 1 4))
|
||||
(bitwise-bit-field 13 1 4)]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(arithmetic-shift [n exact-integer?] [m exact-integer?])
|
||||
|
|
|
|||
|
|
@ -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?]{
|
||||
|
||||
|
|
|
|||
|
|
@ -70,8 +70,9 @@ the result is always a @tech{fixnum}. The @scheme[unsafe-fxlshift] and
|
|||
@scheme[unsafe-fxlshift] is a positive (i.e., left) shift, and
|
||||
@scheme[unsafe-fxrshift] is a negative (i.e., right) shift, where the
|
||||
number of bits to shift must be less than the number of bits used to
|
||||
represent a @tech{fixnum}, and the result is effectively
|
||||
@scheme[bitwise-and]ed with the most negative @tech{fixnum}.}
|
||||
represent a @tech{fixnum}. In the case of @scheme[unsafe-fxlshift],
|
||||
bits in the result beyond the the number of bits used to represent a
|
||||
@tech{fixnum} are effectively replaced with a copy of the high bit.}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
|
|
|
|||
|
|
@ -105,15 +105,15 @@
|
|||
|
||||
(exit (cond
|
||||
[(not (null? jumped-out-tests))
|
||||
(printf "Test suites ended with exns ~s\n" jumped-out-tests)
|
||||
(fprintf (current-error-port) "Test suites ended with exns ~s\n" jumped-out-tests)
|
||||
1]
|
||||
[(null? failed-tests)
|
||||
(printf "All tests passed.\n")
|
||||
0]
|
||||
[else
|
||||
(debug-printf schedule "FAILED tests:\n")
|
||||
(fprintf (current-error-port) "FAILED tests:\n")
|
||||
(for-each (lambda (failed-test)
|
||||
(debug-printf schedule " ~a // ~a\n"
|
||||
(fprintf (current-error-port) " ~a // ~a\n"
|
||||
(car failed-test) (cdr failed-test)))
|
||||
failed-tests)
|
||||
1]))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(load-relative "loadtest.ss")
|
||||
(load-relative "../mzscheme/loadtest.ss")
|
||||
|
||||
(Section 'future)
|
||||
(require scheme/future)
|
||||
|
|
|
|||
|
|
@ -84,7 +84,9 @@ Errors/exceptions and other kinds of control?
|
|||
|
||||
|#
|
||||
|
||||
(random-seed 2)
|
||||
(let ([v (modulo (current-milliseconds) 1000)])
|
||||
(printf "using seed ~a\n" v)
|
||||
(random-seed v))
|
||||
|
||||
(define-language fut
|
||||
;; single value, non-error expressions
|
||||
|
|
@ -185,9 +187,10 @@ Errors/exceptions and other kinds of control?
|
|||
|
||||
(define-namespace-anchor ns-here)
|
||||
|
||||
(let loop ([n 100])
|
||||
(printf ".") (flush-output)
|
||||
(let ([p (gen-prog)])
|
||||
(pretty-print p)
|
||||
(eval p (namespace-anchor->namespace ns-here)))
|
||||
(loop (- n 1)))
|
||||
(let loop ([n 32])
|
||||
(unless (zero? n)
|
||||
(printf ".") (flush-output)
|
||||
(let ([p (gen-prog)])
|
||||
(pretty-print p)
|
||||
(eval p (namespace-anchor->namespace ns-here)))
|
||||
(loop (- n 1))))
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
'("2htdp"
|
||||
"aligned-pasteboard"
|
||||
"deinprogramm"
|
||||
"future"
|
||||
"honu"
|
||||
"match"
|
||||
"macro-debugger"
|
||||
|
|
|
|||
|
|
@ -80,9 +80,9 @@
|
|||
(bytes<? (path->bytes a) (path->bytes b)))))])
|
||||
(test #t equal? (sort rel) (sort rel2))
|
||||
|
||||
(when (eq? (system-type) 'unix)
|
||||
(system "ln -s filelib.ss filelib-link.ss")
|
||||
(system "ln -s . loop-link")
|
||||
(unless (eq? (system-type) 'windows)
|
||||
(make-file-or-directory-link "filelib.ss" "filelib-link")
|
||||
(make-file-or-directory-link "." "loop-link")
|
||||
|
||||
(test (+ 2 (length rel2))
|
||||
fold-files
|
||||
|
|
@ -92,7 +92,7 @@
|
|||
[(file-exists? name) 'file]
|
||||
[(directory-exists? name) 'dir]
|
||||
[else '???]))
|
||||
(when (member name '("filelib-link.ss" "loop-link"))
|
||||
(when (member name '("filelib-link" "loop-link"))
|
||||
(test kind name 'link))
|
||||
(add1 accum))
|
||||
0
|
||||
|
|
@ -107,14 +107,14 @@
|
|||
[(file-exists? name) 'file]
|
||||
[(directory-exists? name) 'dir]
|
||||
[else '???]))
|
||||
(when (member name '("filelib-link.ss" "loop-link"))
|
||||
(when (member name '("filelib-link" "loop-link"))
|
||||
(test kind name 'link))
|
||||
(values (add1 accum) #t))
|
||||
0
|
||||
#f
|
||||
#f)
|
||||
|
||||
(system "rm loop-link")
|
||||
(delete-file "loop-link")
|
||||
|
||||
(test (+ 1 (length rel2))
|
||||
fold-files
|
||||
|
|
@ -122,14 +122,14 @@
|
|||
(test kind values (cond
|
||||
[(file-exists? name) 'file]
|
||||
[else 'dir]))
|
||||
(when (member name '("filelib-link.ss"))
|
||||
(when (member name '("filelib-link"))
|
||||
(test kind name 'file))
|
||||
(add1 accum))
|
||||
0
|
||||
#f
|
||||
#t)
|
||||
|
||||
(system "rm filelib-link.ss")
|
||||
(delete-file "filelib-link")
|
||||
|
||||
'done))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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