peter/weight-balanced-trees
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add set-contains? test, remove NaNs because they cannot be used in the default comparator

Browse source
This commit is contained in:
Peter McGoron 2025-02-16 22:02:46 -05:00
parent b88f195069
commit 52f196f3c0
4 changed files with 67 additions and 47 deletions

4
doc/mcgoron.weight-balanced-trees.internal.scm
View file

@ -64,8 +64,8 @@ all values to the right of `key`.
If a value that compares equal to `key` is found, that value is returned.
Otherwise the result of calling `default` with no arguments is returned.")
((name . "search")
(signature case-lambda ((((comparator? cmp) (balanced? tree) key) *)
(((comparator? cmp) (balanced? tree) key (procedure? default)) *)))
(signature case-lambda ((((comparator? cmp) key (balanced? tree)) *)
(((comparator? cmp) key (balanced? tree) (procedure? default)) *)))
(subsigs (default (lambda () *)))
(desc "
* It is an error if `cmp` does not order `key` and all elements in `tree`.

1
mcgoron/weight-balanced-trees/srfi/113/sets.scm
View file

@ -46,6 +46,7 @@
(define (set-contains? set element)
(let ((found? #t))
(search (set-element-comparator set)
element
(get-node set)
(lambda () (set! found? #f)))
found?))

4
tests/run.scm
View file

@ -26,7 +26,7 @@
(test-runner-current (test-runner-create))
(set-verbosity! '(fails))
(define-library (mcgoron weight-balanced-trees test internal)
#;(define-library (mcgoron weight-balanced-trees test internal)
(import (scheme base)
(chicken condition)
(mcgoron weight-balanced-trees test util)
@ -42,7 +42,7 @@
(include "internal.scm"))
(define-library (mcgoron weight-balanced-trees test srfi 113 sets)
(import (scheme base)
(import (scheme base) (scheme write) (scheme inexact)
(chicken condition)
(except (mcgoron srfi 64) factory)
(srfi 1) (srfi 26) (srfi 64) (srfi 69) (srfi 128)

105
tests/srfi-113-sets.scm
View file

@ -13,24 +13,28 @@
| limitations under the License.
|#
(define test-expensive #f)
(define cmp (make-default-comparator))
(define (orderable-generator)
;; Return a value that can be ordered in an obvious way.
(gsampling (boolean-generator)
(real-generator)
(char-generator)
(string-generator)
(bytevector-generator)))
(gfilter (lambda (x) (or (not (number? x))
(not (nan? x))))
(gsampling (boolean-generator)
(real-generator)
(char-generator)
(string-generator)
(bytevector-generator))))
(define (remove-duplicates generator)
;; Remove duplicates (according to the default comparator) from vectors
;; made by `generator`.
(gmap (lambda (vec)
(let* ((cmp (make-default-comparator))
(table (make-hash-table (cut =? cmp <> <>) hash-by-identity))
(let* ((table (make-hash-table (cut =? cmp <> <>) hash-by-identity))
(n 0))
(vector-for-each
(lambda (value)
(when (hash-table-ref/default table value #f)
(when (not (hash-table-ref/default table value #f))
(hash-table-set! table value #t)
(set! n (+ n 1))))
vec)
@ -43,8 +47,19 @@
new-vec)))
generator))
(define (split-vector gen)
;; Split vectors in half.
(gmap (lambda (vec)
(let* ((len (vector-length vec))
(midpoint (floor (/ len 2))))
(list (vector-copy vec 0 midpoint)
(vector-copy vec (+ midpoint 1) len))))
(gfilter (lambda (vec)
(not (zero? (vector-length vec))))
gen)))
(define (%set . elements)
(apply set (make-default-comparator) elements))
(apply set cmp elements))
;;; ;;;;;;;;;;;;;;;;;;;;
;;; Tests
@ -84,25 +99,24 @@
(test-call "length?" (<= (set-size new-set) (length lst)))
(test-call "subset of inserted" (lset<= equal? set-as-list lst)))))
(test-group "multiple element set using `list->set` procedure"
(test-property (test-create-with-duplicates
(cute list->set (make-default-comparator) <>))
(list (vector-generator-of (orderable-generator)))))
(test-group "multiple element set using `set` procedure"
(test-property (test-create-with-duplicates
(cute apply set (make-default-comparator) <...>))
(list (vector-generator-of (orderable-generator)))))
(test-group "multiple element set using `set-unfold` procedure"
(test-property (test-create-with-duplicates
(when test-expensive
(test-group "multiple element set using `list->set` procedure"
(test-property (test-create-with-duplicates
(cute list->set cmp <>))
(list (vector-generator-of (orderable-generator)))))
(test-group "multiple element set using `set` procedure"
(test-property (test-create-with-duplicates
(cute apply set cmp <...>))
(list (vector-generator-of (orderable-generator)))))
(test-group "multiple element set using `set-unfold` procedure"
(test-property (test-create-with-duplicates
(cute set-unfold
(make-default-comparator)
cmp
null?
car
cdr
<>))
(list (vector-generator-of (orderable-generator)))))
(list (vector-generator-of (orderable-generator))))))
(define (test-create-without-duplicates creator)
(lambda (vec)
@ -116,33 +130,38 @@
(test-equal "length?" (set-size new-set) (length lst))
(test-call "exactly inserted" (lset= equal? set-as-list lst)))))
(test-group "multiple element set using `list->set` procedure, unique elements"
(test-property (test-create-without-duplicates
(cute list->set (make-default-comparator) <>))
(list (remove-duplicates
(when test-expensive
(test-group "multiple element set using `list->set` procedure, unique elements"
(test-property (test-create-without-duplicates
(cute list->set cmp <>))
(list (remove-duplicates
(vector-generator-of
(orderable-generator))))))
(test-group "multiple element set using `set` procedure, unique elements"
(test-property (test-create-without-duplicates
(cute apply set (make-default-comparator) <...>))
(list (remove-duplicates
(test-group "multiple element set using `set` procedure, unique elements"
(test-property (test-create-without-duplicates
(cute apply set cmp <...>))
(list (remove-duplicates
(vector-generator-of
(orderable-generator))))))
(test-group "multiple element set using `set-unfold` procedure, unique elements"
(test-property (test-create-without-duplicates
(cute set-unfold
(make-default-comparator)
null?
car
cdr
<>))
(list (remove-duplicates
(test-group "multiple element set using `set-unfold` procedure, unique elements"
(test-property (test-create-without-duplicates
(cute set-unfold cmp null? car cdr <>))
(list (remove-duplicates
(vector-generator-of
(orderable-generator))))))
(orderable-generator)))))))
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set-contains
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test-group "set-contains?"
(define (set-contains-from vec)
(let ((set (list->set cmp (vector->list vec))))
(vector-for-each
(lambda (value)
(test-call "contains" (set-contains? set value)))
vec)))
(test-property set-contains-from
(list (remove-duplicates (vector-generator-of
(orderable-generator))))))