From 94bb7fb2616f23ba6d81bd06918be4426d7e2257 Mon Sep 17 00:00:00 2001 From: Johan Hidding Date: Thu, 27 Oct 2016 19:19:03 +0200 Subject: [PATCH 1/4] add chez to runtests --- runtests | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/runtests b/runtests index df02d57..31bcdd0 100755 --- a/runtests +++ b/runtests @@ -1,4 +1,4 @@ -#!/bin/sh +#!/bin/bash function run_guile { guile -L .. -x .sls -x .guile.sls -x .ss tests.scm @@ -8,9 +8,14 @@ function run_racket { racket tests.scm } +function run_chez { + scheme --libdirs ..:${CHEZSCHEMELIBDIRS} --script tests.scm +} + case "$1" in guile) run_guile ;; racket) run_racket ;; - all) run_guile; run_racket ;; + chez) run_chez ;; + all) run_guile; run_racket; run_chez ;; *) run_guile ;; esac From df31be3211602daefa94cd01033f71a3754b2fdb Mon Sep 17 00:00:00 2001 From: Johan Hidding Date: Sun, 30 Oct 2016 22:30:18 +0100 Subject: [PATCH 2/4] accessor function for the minimum priority of a PSQ: `psq-min-priority`. --- psqs.sls | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/psqs.sls b/psqs.sls index 6bf7395..6678091 100644 --- a/psqs.sls +++ b/psqs.sls @@ -107,6 +107,7 @@ psq-contains? ;; priority queue operations psq-min + psq-min-priority psq-delete-min psq-pop ;; ranged query operations @@ -302,6 +303,12 @@ "Can't take the minimum of an empty priority search queue")) (winner-key tree)) +(define (min-priority tree) + (when (void? tree) + (assertion-violation 'psq-min-priority + "Can't take the minimum of an empty priority search queue")) + (winner-priority tree)) + (define (pop tree key Date: Thu, 28 Dec 2017 01:05:38 +0100 Subject: [PATCH 3/4] tests running on chez-test now --- .gitignore | 4 +- bbtrees.sls => lib/pfds/bbtrees.sls | 0 deques.sls => lib/pfds/deques.sls | 0 {deques => lib/pfds/deques}/naive.sls | 0 .../pfds/deques}/private/condition.sls | 0 dlists.sls => lib/pfds/dlists.sls | 0 fingertrees.sls => lib/pfds/fingertrees.sls | 0 hamts.sls => lib/pfds/hamts.sls | 0 heaps.sls => lib/pfds/heaps.sls | 0 {private => lib/pfds/private}/alists.sls | 0 {private => lib/pfds/private}/bitwise.sls | 0 {private => lib/pfds/private}/lazy-lists.sls | 0 {private => lib/pfds/private}/vectors.sls | 0 psqs.sls => lib/pfds/psqs.sls | 0 queues.sls => lib/pfds/queues.sls | 0 {queues => lib/pfds/queues}/naive.sls | 0 .../pfds/queues}/private/condition.sls | 0 sequences.sls => lib/pfds/sequences.sls | 0 sets.sls => lib/pfds/sets.sls | 0 test/bbtrees.scm | 185 ++++++++++++++++++ test/deques.scm | 119 +++++++++++ test/fingertrees.scm | 180 +++++++++++++++++ test/hamts.scm | 140 +++++++++++++ test/heaps.scm | 70 +++++++ test/psqs.scm | 143 ++++++++++++++ test/queues.scm | 55 ++++++ test/sequences.scm | 22 +++ test/sets.scm | 93 +++++++++ test/test-pfds.scm | 26 +++ test/utils.scm | 15 ++ tests/bbtrees.sls | 185 ------------------ tests/deques.sls | 120 ------------ tests/fingertrees.sls | 181 ----------------- tests/hamts.sls | 141 ------------- tests/heaps.sls | 71 ------- tests/psqs.sls | 144 -------------- tests/queues.sls | 56 ------ tests/sequences.sls | 23 --- tests/sets.sls | 94 --------- tests/utils.sls | 61 ------ 40 files changed, 1050 insertions(+), 1078 deletions(-) rename bbtrees.sls => lib/pfds/bbtrees.sls (100%) rename deques.sls => lib/pfds/deques.sls (100%) rename {deques => lib/pfds/deques}/naive.sls (100%) rename {deques => lib/pfds/deques}/private/condition.sls (100%) rename dlists.sls => lib/pfds/dlists.sls (100%) rename fingertrees.sls => lib/pfds/fingertrees.sls (100%) rename hamts.sls => lib/pfds/hamts.sls (100%) rename heaps.sls => lib/pfds/heaps.sls (100%) rename {private => lib/pfds/private}/alists.sls (100%) rename {private => lib/pfds/private}/bitwise.sls (100%) rename {private => lib/pfds/private}/lazy-lists.sls (100%) rename {private => lib/pfds/private}/vectors.sls (100%) rename psqs.sls => lib/pfds/psqs.sls (100%) rename queues.sls => lib/pfds/queues.sls (100%) rename {queues => lib/pfds/queues}/naive.sls (100%) rename {queues => lib/pfds/queues}/private/condition.sls (100%) rename sequences.sls => lib/pfds/sequences.sls (100%) rename sets.sls => lib/pfds/sets.sls (100%) create mode 100644 test/bbtrees.scm create mode 100644 test/deques.scm create mode 100644 test/fingertrees.scm create mode 100644 test/hamts.scm create mode 100644 test/heaps.scm create mode 100644 test/psqs.scm create mode 100644 test/queues.scm create mode 100644 test/sequences.scm create mode 100644 test/sets.scm create mode 100644 test/test-pfds.scm create mode 100644 test/utils.scm delete mode 100644 tests/bbtrees.sls delete mode 100644 tests/deques.sls delete mode 100644 tests/fingertrees.sls delete mode 100644 tests/hamts.sls delete mode 100644 tests/heaps.sls delete mode 100644 tests/psqs.sls delete mode 100644 tests/queues.sls delete mode 100644 tests/sequences.sls delete mode 100644 tests/sets.sls delete mode 100644 tests/utils.sls diff --git a/.gitignore b/.gitignore index a691dc4..596cff8 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,2 @@ -compiled/* -private/compiled/* +.*.swp +*~ diff --git a/bbtrees.sls b/lib/pfds/bbtrees.sls similarity index 100% rename from bbtrees.sls rename to lib/pfds/bbtrees.sls diff --git a/deques.sls b/lib/pfds/deques.sls similarity index 100% rename from deques.sls rename to lib/pfds/deques.sls diff --git a/deques/naive.sls b/lib/pfds/deques/naive.sls similarity index 100% rename from deques/naive.sls rename to lib/pfds/deques/naive.sls diff --git a/deques/private/condition.sls b/lib/pfds/deques/private/condition.sls similarity index 100% rename from deques/private/condition.sls rename to lib/pfds/deques/private/condition.sls diff --git a/dlists.sls b/lib/pfds/dlists.sls similarity index 100% rename from dlists.sls rename to lib/pfds/dlists.sls diff --git a/fingertrees.sls b/lib/pfds/fingertrees.sls similarity index 100% rename from fingertrees.sls rename to lib/pfds/fingertrees.sls diff --git a/hamts.sls b/lib/pfds/hamts.sls similarity index 100% rename from hamts.sls rename to lib/pfds/hamts.sls diff --git a/heaps.sls b/lib/pfds/heaps.sls similarity index 100% rename from heaps.sls rename to lib/pfds/heaps.sls diff --git a/private/alists.sls b/lib/pfds/private/alists.sls similarity index 100% rename from private/alists.sls rename to lib/pfds/private/alists.sls diff --git a/private/bitwise.sls b/lib/pfds/private/bitwise.sls similarity index 100% rename from private/bitwise.sls rename to lib/pfds/private/bitwise.sls diff --git a/private/lazy-lists.sls b/lib/pfds/private/lazy-lists.sls similarity index 100% rename from private/lazy-lists.sls rename to lib/pfds/private/lazy-lists.sls diff --git a/private/vectors.sls b/lib/pfds/private/vectors.sls similarity index 100% rename from private/vectors.sls rename to lib/pfds/private/vectors.sls diff --git a/psqs.sls b/lib/pfds/psqs.sls similarity index 100% rename from psqs.sls rename to lib/pfds/psqs.sls diff --git a/queues.sls b/lib/pfds/queues.sls similarity index 100% rename from queues.sls rename to lib/pfds/queues.sls diff --git a/queues/naive.sls b/lib/pfds/queues/naive.sls similarity index 100% rename from queues/naive.sls rename to lib/pfds/queues/naive.sls diff --git a/queues/private/condition.sls b/lib/pfds/queues/private/condition.sls similarity index 100% rename from queues/private/condition.sls rename to lib/pfds/queues/private/condition.sls diff --git a/sequences.sls b/lib/pfds/sequences.sls similarity index 100% rename from sequences.sls rename to lib/pfds/sequences.sls diff --git a/sets.sls b/lib/pfds/sets.sls similarity index 100% rename from sets.sls rename to lib/pfds/sets.sls diff --git a/test/bbtrees.scm b/test/bbtrees.scm new file mode 100644 index 0000000..a4d5786 --- /dev/null +++ b/test/bbtrees.scm @@ -0,0 +1,185 @@ +(library (test bbtrees) + (export bbtrees) + (import (rnrs (6)) + (chez-test suite) + + (test utils) + (pfds bbtrees)) + + (define-test-suite bbtrees + "Tests for the bounded balance tree imlementation") + + (define-test-case bbtrees empty-tree () + (test-predicate bbtree? (make-bbtree <)) + (test-eqv 0 (bbtree-size (make-bbtree <)))) + + (define-test-case bbtrees bbtree-set () + (let* ([tree1 (bbtree-set (make-bbtree <) 1 'a)] + [tree2 (bbtree-set tree1 2 'b)] + [tree3 (bbtree-set tree2 1 'c )]) + (test-eqv 1 (bbtree-size tree1)) + (test-eqv 'a (bbtree-ref tree1 1)) + (test-eqv 2 (bbtree-size tree2)) + (test-eqv 'b (bbtree-ref tree2 2)) + (test-eqv 2 (bbtree-size tree3)) + (test-eqv 'c (bbtree-ref tree3 1)) + (test-eqv #f (bbtree-ref tree1 #xdeadbeef #f)) + (test-eqv 'not-in (bbtree-ref tree1 #xdeadbeef 'not-in)) + (test-exn assertion-violation? (bbtree-ref tree3 20)))) + + + (define-test-case bbtrees bbtree-update () + (let ([bb (alist->bbtree '(("foo" . 10) ("bar" . 12)) stringbbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) string))) + (test-eqv #t (bbtree-fold-right (lambda args #f) #t (make-bbtree >))) + ;; associative operations + (test-eqv 20 (bbtree-fold (lambda (key value accum) (+ value accum)) 0 bb)) + (test-eqv 20 (bbtree-fold-right (lambda (key value accum) (+ value accum)) 0 bb)) + ;; non-associative operations + (test-equal '("foo" "baz" "bar") + (bbtree-fold (lambda (key value accum) (cons key accum)) '() bb)) + (test-equal '("bar" "baz" "foo") + (bbtree-fold-right (lambda (key value accum) (cons key accum)) '() bb))))) + + (define-test-case bbtrees bbtree-map + (let ((empty (make-bbtree <)) + (bb (alist->bbtree '((#\a . foo) (#\b . bar) (#\c . baz) (#\d . quux)) + charalist (bbtree-map (lambda (x) (cons x x)) bb))) + (test-equal '((#\a . "foo") (#\b . "bar") (#\c . "baz") (#\d . "quux")) + (bbtree->alist (bbtree-map symbol->string bb)))))) + + (define-test-case bbtrees conversion () + (test-eqv '() (bbtree->alist (make-bbtree <))) + (test-eqv 0 (bbtree-size (alist->bbtree '() <))) + (test-equal '(("bar" . 12) ("baz" . 7) ("foo" . 1)) + (bbtree->alist (alist->bbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) stringalist + (alist->bbtree (map (lambda (x) (cons x 'dummy)) + l) + <)))))) + (test-equal (list-sort < l) (tree-sort < l)))) + + (define-test-case bbtrees bbtree-union + (let ([empty (make-bbtree charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) + charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) + charlist "abcdefghijlmnopqrstuvwxyz")] + [b1 (map (lambda (x) (cons x (char->integer x))) l)] + [b2 (map (lambda (x) (cons x #f)) l)]) + (test-equal b1 + (bbtree->alist (bbtree-union (alist->bbtree b1 charbbtree b2 charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) + charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) + charalist (bbtree-intersection bbtree1 bbtree2))) + ;; check this holds on larger bbtrees + (let* ([l (string->list "abcdefghijlmnopqrstuvwxyz")] + [b1 (map (lambda (x) (cons x (char->integer x))) l)] + [b2 (map (lambda (x) (cons x #f)) l)]) + (test-equal b1 + (bbtree->alist (bbtree-intersection (alist->bbtree b1 charbbtree b2 charalist (bbtree-intersection bbtree1 bbtree2)) + (bbtree->alist + (bbtree-difference bbtree1 + (bbtree-difference bbtree1 bbtree2))))))) + + (define-test-case bbtrees bbtree-difference + (let ([empty (make-bbtree charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) + charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) + charalist (bbtree-difference bbtree1 bbtree2))) + (test-equal '((#\p . 12) (#\s . 15)) + (bbtree->alist (bbtree-difference bbtree2 bbtree1)))))) + + (define-test-case bbtrees bbtree-indexing + (let* ([l (string->list "abcdefghijklmno")] + [bb (alist->bbtree (map (lambda (x) (cons x #f)) l) charlist (list->deque list)))) + (l1 '()) + (l2 '(1 2 3)) + (l3 '(4 5 6 7 8 9 10)) + (l4 (string->list "abcdefghijklmnopqrstuvwxyz"))) + (test-equal l1 (id-list l1)) + (test-equal l2 (id-list l2)) + (test-equal l3 (id-list l3)) + (test-equal l4 (id-list l4)))) + +) diff --git a/test/fingertrees.scm b/test/fingertrees.scm new file mode 100644 index 0000000..acc9c57 --- /dev/null +++ b/test/fingertrees.scm @@ -0,0 +1,180 @@ +(library (test fingertrees) + (export fingertrees) + (import (rnrs (6)) + (chez-test suite) + (test utils) + (rename (pfds fingertrees) + (make-fingertree %make-fingertree) + (list->fingertree %list->fingertree)) + ) + + ;; Right now, I am not testing the monoidal parts of fingertrees, so + ;; we use constructor that replaces these with arbitrary values + (define (make-fingertree) + (%make-fingertree 0 (lambda (x y) x) (lambda (x) x))) + + (define (list->fingertree l) + (%list->fingertree l 0 (lambda (x y) x) (lambda (x) x))) + + (define (list->product-tree l) + (%list->fingertree l 1 * values)) + + (define (list->last-tree l) + (define *cookie* (cons 'no 'last)) + (define (pick x y) + (if (eq? *cookie* y) + x + y)) + (%list->fingertree l *cookie* pick values)) + + (define-test-suite fingertrees + "Tests for the fingertree implementation") + + (define-test-case fingertrees empty-tree () + (test-predicate fingertree? (make-fingertree)) + (test-predicate fingertree-empty? (make-fingertree))) + + (define-test-case fingertrees construction + (let ((l1 '(a b c d e f)) + (l2 '((#t . f) (#t . e) (#t . d) (#t . c) (#t . b) (#t . a))) + (l3 '((#f . a) (#f . b) (#f . c) (#f . d) (#f . e) (#f . f))) + (l4 '((#f . b) (#f . c) (#t . a) (#f . d) (#f . e) (#f . f))) + (l5 '((#f . e) (#t . d) (#t . c) (#t . b) (#f . f) (#t . a))) + (make (lambda (alist) + (fold-left (lambda (tree pair) + (if (car pair) + (fingertree-cons (cdr pair) tree) + (fingertree-snoc tree (cdr pair)))) + (make-fingertree) + alist))) + (empty (make-fingertree))) + (test-case construction () + (test-eqv #f (fingertree-empty? (fingertree-cons #f empty))) + (test-eqv #f (fingertree-empty? (fingertree-snoc empty #f))) + (test-equal l1 (fingertree->list (make l2))) + (test-equal l1 (fingertree->list (make l3))) + (test-equal l1 (fingertree->list (make l4))) + (test-equal l1 (fingertree->list (make l5)))))) + + (define-test-case fingertrees removal + (let* ((l1 '(a b c d e f)) + (f1 (list->fingertree l1)) + (f2 (make-fingertree))) + (test-case removal () + (test-exn fingertree-empty-condition? (fingertree-uncons f2)) + (test-exn fingertree-empty-condition? (fingertree-unsnoc f2)) + (let-values (((head tail) (fingertree-uncons f1))) + (test-eqv (car l1) head) + (test-equal (cdr l1) (fingertree->list tail))) + (let*-values (((init last) (fingertree-unsnoc f1)) + ((l*) (reverse l1)) + ((l1-last) (car l*)) + ((l1-init) (reverse (cdr l*)))) + (test-eqv l1-last last) + (test-equal l1-init (fingertree->list init)))))) + + (define-test-case fingertrees conversion + (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 + 183 199 254 78 210 14 131 10 220 205 203 125 111 42 249)) + (l2 '(25 168 21 246 39 211 60 83 103 161 192 201 31 253 + 156 218 204 186 155 117))) + (test-case conversion () + (test-equal '() (fingertree->list (list->fingertree '()))) + (test-equal l1 (fingertree->list (list->fingertree l1))) + (test-equal l2 (fingertree->list (list->fingertree l2)))))) + + (define-test-case fingertrees ftree-append + (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 + 183 199 254 78 210 14 131 10 220 205 203 125 111 42 249)) + (l2 '(25 168 21 246 39 211 60 83 103 161 192 201 31 253 + 156 218 204 186 155 117)) + (append* (lambda (a b) + (fingertree->list + (fingertree-append + (list->fingertree a) + (list->fingertree b)))))) + (test-case ftree-append () + (test-equal (append l1 '()) (append* l1 '())) + (test-equal (append '() l1) (append* '() l1)) + (test-equal (append l1 l2) (append* l1 l2)) + (test-equal (append l1 l1) (append* l1 l1)) + (test-equal (append l1 l2) (append* l1 l2))))) + + (define-test-case fingertrees monoidal-operation + (let ((l1 '(31 238 100 129 6 169 239 150 96 141 + 207 208 190 45 56 183 199 254 78 210)) + (l2 '((31 238 100 129 6) (169 239 150) (96 141 207 208 190) + () (45 56 183 199) (254 78 210))) + (car/default (lambda (dflt) (lambda (x) (if (pair? x) (car x) dflt)))) + (list->sum-tree (lambda (l1) (%list->fingertree l1 0 + values)))) + (test-case moniodal-operation () + (test-equal 254 (fingertree-measure (%list->fingertree l1 0 max values))) + (test-equal 6 (fingertree-measure (%list->fingertree l1 1000 min values))) + (test-equal l1 (fingertree-measure (%list->fingertree l2 '() append values))) + (test-equal 595 (fingertree-measure + (%list->fingertree l2 0 + (car/default 0)))) + ;; sum of l1 is 4239 + (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 0)) + (list->sum-tree l1)))) + (fingertree->list (fingertree-append a b)))) + (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 1000)) + (list->sum-tree l1)))) + (fingertree->list (fingertree-append a b)))) + (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 2000)) + (list->sum-tree l1)))) + (fingertree->list (fingertree-append a b)))) + (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 5000)) + (list->sum-tree l1)))) + (fingertree->list (fingertree-append a b))))))) + + (define-test-case fingertrees fingertree-folds + (let* ((l '(31 238 100 129 6 169 239 150 96 141 + 207 208 190 45 56 183 199 254 78 210)) + (lrev (reverse l)) + (total (apply + l)) + (ft (list->fingertree l))) + (test-case fingertree-folds () + ;; empty case + (test-eqv #t (fingertree-fold (lambda _ #f) #t (make-fingertree))) + (test-eqv #t (fingertree-fold-right (lambda _ #f) #t (make-fingertree))) + ;; associative operations + (test-eqv total (fingertree-fold + 0 ft)) + (test-eqv total (fingertree-fold-right + 0 ft)) + ;; non-associative operations + (test-equal lrev (fingertree-fold cons '() ft)) + (test-equal l (fingertree-fold-right cons '() ft))))) + + (define-test-case fingertrees reversal + (let ((rev (lambda (l) + (fingertree->list + (fingertree-reverse (list->fingertree l))))) + (id (lambda (l) + (fingertree->list + (fingertree-reverse + (fingertree-reverse (list->fingertree l)))))) + (l1 '(126 6 48 86 2 119 233 92 230 160)) + (l2 '(25 168 21 246 39 211 60 83 103 161 + 192 201 31 253 156 218 204 186 155 117))) + (test-case reversal () + ;; behaves the same as regular reverse on lists + (test-eqv '() (rev '())) + (test-equal '(1) (rev '(1))) + (test-equal '(6 5 4 3 2 1) (rev '(1 2 3 4 5 6))) + (test-equal (reverse l1) (rev l1)) + (test-equal (reverse l2) (rev l2)) + ;; double reversal is the the same list + (test-equal l1 (id l1)) + (test-equal l2 (id l2)) + ;; a fingertree will have the same measure as its reverse if + ;; the monoid is commutative + (test-equal (fingertree-measure (list->product-tree l1)) + (fingertree-measure + (fingertree-reverse (list->product-tree l1)))) + ;; otherwise they are not necessarily the same + ;; in this case, they are the same only if the first and last + ;; elements are the same + (test-not + (equal? (fingertree-measure (list->last-tree l2)) + (fingertree-measure (fingertree-reverse (list->product-tree l2)))))))) + +) diff --git a/test/hamts.scm b/test/hamts.scm new file mode 100644 index 0000000..a4e68a5 --- /dev/null +++ b/test/hamts.scm @@ -0,0 +1,140 @@ +(library (test hamts) + (export hamts) + (import (rnrs (6)) + (chez-test suite) + (test utils) + (pfds hamts)) + + (define (make-string-hamt) + (make-hamt string-hash string=?)) + + (define (compare-string-alist l1 l2) + (lambda (l1 l2) + (define (compare x y) (stringhamt / distinct keys + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) + (h (alist->hamt l string-hash string=?))) + (test-equal (list 1 2 3) + (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) + ;; alist->hamt / overlapping keys (leftmost shadows) + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("a" . 4))) + (h (alist->hamt l string-hash string=?))) + (test-equal (list 1 2 3) + (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) + ;; hamt->alist / distinct keys means left inverse + (let ((l '(("a" . 1) ("b" . 2) ("c" . 3)))) + (test-compare compare-string-alist l + (hamt->alist (alist->hamt l string-hash string=?))))) + + (define-test-case hamts hamt-folding () + ;; count size + (let ((h (alist->hamt '(("a" . 1) ("b" . 2) ("c" . 3)) string-hash string=?)) + (increment (lambda (k v acc) (+ 1 acc)))) + (test-equal 3 (hamt-fold increment 0 h))) + ;; copy hamt + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) + (h (alist->hamt l string-hash string=?)) + (add (lambda (k v acc) (hamt-set acc k v)))) + (test-compare compare-string-alist l + (hamt->alist (hamt-fold add (make-string-hamt) h))))) + + (define-test-case hamts hamt-removal () + ;; removed key exists + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) + (h (alist->hamt l string-hash string=?))) + (test-case key-exists () + (test-compare compare-string-alist '(("b" . 2) ("c" . 3)) (hamt-delete h "a")) + (test-eqv (- (hamt-size h) 1) (hamt-size (hamt-delete h "a"))))) + ;; removed key does not exist + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) + (h (alist->hamt l string-hash string=?))) + (test-case key-not-exists () + (test-compare compare-string-alist l (hamt-delete h "d")) + (test-eqv (hamt-size h) (hamt-size (hamt-delete h "d")))))) + + (define-test-case hamts hamt-updates () + ;; update non-existent key + (test-eqv 1 (hamt-ref (hamt-update (make-string-hamt) "foo" add1 0) "foo" #f)) + ;; update existing key + (let ((h (hamt-set (make-string-hamt) "foo" 12))) + (test-eqv 13 (hamt-ref (hamt-update h "foo" add1 0) "foo" #f)))) + + (define-test-case hamts hamt-collisions () + ;; a bad hash function does not cause problems + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) + (h (alist->hamt l bad-hash string=?))) + (test-compare compare-string-alist l (hamt->alist h))) + ;; stress test, since bigger amounts data usually finds bugs + (let ((insert (lambda (hamt val) (hamt-set hamt val val))) + (hash (lambda (n) (exact (floor (/ n 2)))))) + (test-eqv 100 (hamt-size (fold-left insert (make-hamt hash =) (iota 100))))) + ;; collision removal + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4))) + (h (alist->hamt l bad-hash string=?))) + (test-compare compare-string-alist '() + (fold-left (lambda (hamt str) (hamt-delete hamt str)) + h + '("b" "notexists" "d" "a" "c" "notexists")))) + ;; stress test removal + (let* ((al (map (lambda (x) (cons x #t)) (iota 100))) + (hash (lambda (n) (exact (floor (/ n 2))))) + (h (alist->hamt al hash =))) + (test-eqv 94 (hamt-size (fold-left (lambda (h s) (hamt-delete h s)) + h + (list 1 93 72 6 24 48))))) + ;; collision updates + (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) + (h (alist->hamt l bad-hash string=?))) + (test-compare compare-string-alist + '(("a" . 2) ("b" . 3) ("c" . 4)) + (fold-left (lambda (hamt key) + (hamt-update hamt key add1 0)) + h + '("a" "b" "c"))))) + + (define-test-case hamts hamt-mapping () + (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) + (h (alist->hamt l string-hash string=?))) + (test-compare compare-string-alist l + (hamt->alist (hamt-map (lambda (x) x) h)))) + (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) + (h (alist->hamt l string-hash string=?)) + (stringify (lambda (n) (string (integer->char n))))) + (test-compare compare-string-alist + '(("a". "a") ("b" . "b") ("c" . "c")) + (hamt->alist (hamt-map stringify h)))) + (let ((h (alist->hamt '(("a" . 97) ("b" . 98) ("c" . 99)) string-hash string=?))) + (test-eqv (hamt-size h) (hamt-size (hamt-map (lambda (x) x) h))))) + +) diff --git a/test/heaps.scm b/test/heaps.scm new file mode 100644 index 0000000..cd8cddb --- /dev/null +++ b/test/heaps.scm @@ -0,0 +1,70 @@ +(library (test heaps) + (export heaps) + (import (rnrs (6)) + (chez-test suite) + (test utils) + (pfds heaps)) + + (define-test-suite heaps + "Tests for the leftist heap implementation") + + (define-test-case heaps empty-heap () + (test-predicate heap? (make-heap <)) + (test-predicate heap-empty? (make-heap <)) + (test-eqv 0 (heap-size (heap <))) + ) + + (define-test-case heaps heap-insertion + (let ((h1 (heap < 7 1 13 9 5 3 11)) + (h2 (heap < 4 2 8 10 6 0 12))) + (test-case heap-insertion () + (test-equal (+ 1 (heap-size h1)) + (heap-size (heap-insert h1 0))) + (test-equal (+ 1 (heap-size h1)) + (heap-size (heap-insert h1 1))) + (test-equal '(1 2 3 5 7 9 11 13) + (heap->list (heap-insert h1 2))) + (test-equal '(1 3 4 5 7 9 11 13) + (heap->list (heap-insert h1 4))) + (test-equal '(1 3 5 7 9 11 12 13) + (heap->list (heap-insert h1 12))) + (test-equal '(1 3 5 7 9 11 13 100) + (heap->list (heap-insert h1 100))) + (test-equal '(-2 0 2 4 6 8 10 12) + (heap->list (heap-insert h2 -2))) + (test-equal '(0 0 2 4 6 8 10 12) + (heap->list (heap-insert h2 0))) + (test-equal '(0 2 4 6 8 8 10 12) + (heap->list (heap-insert h2 8)))))) + + (define-test-case heaps heap-deletion + (let ((h1 (heap < 7 1 13 9 5 3 11)) + (h2 (heap < 4 2 8 6 0))) + (test-case heap-deletion () + (test-equal (- (heap-size h1) 1) + (heap-size (heap-delete-min h1))) + (test-equal 1 (heap-min h1)) + (test-equal 0 (heap-min h2)) + (test-equal 1 (heap-min (heap-delete-min (heap-insert h1 -10)))) + (test-equal 3 (heap-size (heap-delete-min (heap-delete-min h2)))) + (test-equal 4 (heap-min (heap-delete-min (heap-delete-min h2)))) + (test-equal '(7 9 11 13) + (heap->list + (heap-delete-min (heap-delete-min (heap-delete-min h1))))) + (test-exn heap-empty-condition? (heap-pop (make-heap <))) + (test-exn heap-empty-condition? (heap-delete-min (make-heap <))) + (test-exn heap-empty-condition? (heap-min (make-heap <)))))) + + (define-test-case heaps sorting + (let ((l1 '(129 109 146 175 229 48 225 239 129 41 + 38 13 187 15 207 70 64 198 79 125)) + (l2 '(72 17 220 158 164 133 20 78 96 230 25 + 19 13 17 58 223 37 214 94 195 93 174))) + (test-case sorting () + (test-equal '() (heap-sort < '())) + (test-equal (list-sort < l1) + (heap-sort < l1)) + (test-equal (list-sort < l2) + (heap-sort < l2))))) + +) diff --git a/test/psqs.scm b/test/psqs.scm new file mode 100644 index 0000000..e8a4eea --- /dev/null +++ b/test/psqs.scm @@ -0,0 +1,143 @@ +(library (test psqs) + (export psqs) + (import (rnrs (6)) + (chez-test suite) + (test utils) + (pfds psqs)) + + (define (alist->psq alist keypsq '((#\a . 10) (#\b . 33) (#\c . 3)) + charpsq '((#\a . 10) (#\b . 33) (#\c . 3) (#\d . 23) (#\e . 7)) + charpsq alist charqueue list))) + (test-eqv 5 (queue-length queue)) + (test-equal list (queue->list queue)))) + +) diff --git a/test/sequences.scm b/test/sequences.scm new file mode 100644 index 0000000..b9c321c --- /dev/null +++ b/test/sequences.scm @@ -0,0 +1,22 @@ +(library (test sequences) + (export sequences) + (import (rnrs (6)) + (chez-test suite) + (test utils) + (pfds sequences)) + + (define-test-suite sequences + "Tests for the sequences implementation") + ;; Note: at the moment, sequences are a trivial instantiation of + ;; fingertrees, and so are pretty much covered by the fingertrees + ;; tests. + + (define-test-case sequences sequences-bugs + (let ((s (sequence 'zero 'one 'two))) + (test-case sequences-bugs () + (test-eqv 'zero (sequence-ref s 0)) + (test-eqv 'two (sequence-ref s 2)) + (test-exn assertion-violation? (sequence-ref s -1)) + (test-exn assertion-violation? (sequence-ref s 3))))) + +) diff --git a/test/sets.scm b/test/sets.scm new file mode 100644 index 0000000..b8c418e --- /dev/null +++ b/test/sets.scm @@ -0,0 +1,93 @@ +(library (test sets) + (export sets) + (import (rnrs (6)) + (chez-test suite) + (test utils) + (pfds sets)) + + (define-test-suite sets + "Tests for the set implementation") + + (define-test-case sets set-basics + (let ([empty (make-set stringset '("foo" "bar" "baz") stringset '("foo" "bar" "baz" "quux" "zot") stringset '(0 2 5 7 12 2 3 62 5) <)] + [set2 (list->set '(94 33 44 2 73 55 48 92 98 29 + 28 98 55 20 69 5 33 53 89 50) + <)] + [sets (list empty set1 set2)]) + (test-case set-operations () + (assert (for-all (lambda (x) (set=? x (set-union x x))) sets)) + (assert (for-all (lambda (x) (set=? x (set-intersection x x))) sets)) + (assert (for-all (lambda (x) (set=? empty (set-difference x x))) sets)) + (assert (for-all (lambda (x) (set=? x (set-union empty x))) sets)) + (assert (for-all (lambda (x) (set=? empty (set-intersection empty x))) sets)) + (assert (for-all (lambda (x) (set=? x (set-difference x empty))) sets)) + (assert (for-all (lambda (x) (set=? empty (set-difference empty x))) sets)) + + (assert (set=? (set-union set1 set2) (set-union set2 set1))) + (assert (set=? (set-union set1 set2) + (list->set '(0 2 3 69 7 73 12 20 89 28 + 29 94 5 33 98 92 44 48 50 53 + 55 62) + <))) + + (assert (set=? (set-intersection set1 set2) (set-intersection set2 set1))) + (assert (set=? (set-intersection set1 set2) + (list->set '(2 5) <))) + (assert (set=? (set-difference set1 set2) + (list->set '(0 3 12 62 7) <))) + (assert (set=? (set-difference set2 set1) + (list->set '(33 98 69 73 44 48 92 50 20 53 + 55 89 28 29 94) + <)))))) + + (define-test-case sets set-conversion () + (test-eqv '() (set->list (make-set <))) + (test-eqv 0 (set-size (list->set '() <))) + (test-equal (string->list "abcdefghijklmno") + (list-sort charlist + (list->set (string->list "abcdefghijklmno") charlist (fold-left set-insert (make-set <) '(0 0 0 0))))) + + (define-test-case sets set-iterators () + (test-eqv 0 (set-fold + 0 (list->set '() <))) + (test-eqv 84 (set-fold + 0 (list->set '(3 12 62 7) <))) + (test-eqv 499968 (set-fold * 1 (list->set '(3 12 62 7 8 4) <)))) + +) diff --git a/test/test-pfds.scm b/test/test-pfds.scm new file mode 100644 index 0000000..f91d7a2 --- /dev/null +++ b/test/test-pfds.scm @@ -0,0 +1,26 @@ +(import (rnrs (6)) + (chez-test suite) + (chez-test reports) + (srfi :48) + (test bbtrees) + (test deques) + (test fingertrees) + (test hamts) + (test heaps) + (test psqs) + (test queues) + (test sequences) + (test sets)) + +(define (test-all) + (format #t "~%") + (print-report (run-suite bbtrees)) + (print-report (run-suite deques)) + (print-report (run-suite fingertrees)) + (print-report (run-suite hamts)) + (print-report (run-suite heaps)) + (print-report (run-suite psqs)) + (print-report (run-suite queues)) + (print-report (run-suite sequences)) + (print-report (run-suite sets)) +) diff --git a/test/utils.scm b/test/utils.scm new file mode 100644 index 0000000..d9530df --- /dev/null +++ b/test/utils.scm @@ -0,0 +1,15 @@ +(library (test utils) + (export add1 iota) + (import (rnrs (6))) + + (define (add1 x) + (+ x 1)) + + (define (iota n) + (define (recur x) + (if (< x n) + (cons x (recur (+ x 1))) + '())) + (assert (integer? n)) + (recur 0)) +) diff --git a/tests/bbtrees.sls b/tests/bbtrees.sls deleted file mode 100644 index 2e5d1a8..0000000 --- a/tests/bbtrees.sls +++ /dev/null @@ -1,185 +0,0 @@ -#!r6rs -(library (pfds tests bbtrees) -(export bbtrees) -(import (rnrs) - (wak trc-testing) - (pfds tests utils) - (pfds bbtrees)) - -(define-test-suite bbtrees - "Tests for the bounded balance tree imlementation") - -(define-test-case bbtrees empty-tree () - (test-predicate bbtree? (make-bbtree <)) - (test-eqv 0 (bbtree-size (make-bbtree <)))) - -(define-test-case bbtrees bbtree-set () - (let* ([tree1 (bbtree-set (make-bbtree <) 1 'a)] - [tree2 (bbtree-set tree1 2 'b)] - [tree3 (bbtree-set tree2 1 'c )]) - (test-eqv 1 (bbtree-size tree1)) - (test-eqv 'a (bbtree-ref tree1 1)) - (test-eqv 2 (bbtree-size tree2)) - (test-eqv 'b (bbtree-ref tree2 2)) - (test-eqv 2 (bbtree-size tree3)) - (test-eqv 'c (bbtree-ref tree3 1)) - (test-eqv #f (bbtree-ref tree1 #xdeadbeef #f)) - (test-eqv 'not-in (bbtree-ref tree1 #xdeadbeef 'not-in)) - (test-exn assertion-violation? (bbtree-ref tree3 20)))) - - -(define-test-case bbtrees bbtree-update () - (let ([bb (alist->bbtree '(("foo" . 10) ("bar" . 12)) stringbbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) string))) - (test-eqv #t (bbtree-fold-right (lambda args #f) #t (make-bbtree >))) - ;; associative operations - (test-eqv 20 (bbtree-fold (lambda (key value accum) (+ value accum)) 0 bb)) - (test-eqv 20 (bbtree-fold-right (lambda (key value accum) (+ value accum)) 0 bb)) - ;; non-associative operations - (test-equal '("foo" "baz" "bar") - (bbtree-fold (lambda (key value accum) (cons key accum)) '() bb)) - (test-equal '("bar" "baz" "foo") - (bbtree-fold-right (lambda (key value accum) (cons key accum)) '() bb))))) - -(define-test-case bbtrees bbtree-map - (let ((empty (make-bbtree <)) - (bb (alist->bbtree '((#\a . foo) (#\b . bar) (#\c . baz) (#\d . quux)) - charalist (bbtree-map (lambda (x) (cons x x)) bb))) - (test-equal '((#\a . "foo") (#\b . "bar") (#\c . "baz") (#\d . "quux")) - (bbtree->alist (bbtree-map symbol->string bb)))))) - -(define-test-case bbtrees conversion () - (test-eqv '() (bbtree->alist (make-bbtree <))) - (test-eqv 0 (bbtree-size (alist->bbtree '() <))) - (test-equal '(("bar" . 12) ("baz" . 7) ("foo" . 1)) - (bbtree->alist (alist->bbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) stringalist - (alist->bbtree (map (lambda (x) (cons x 'dummy)) - l) - <)))))) - (test-equal (list-sort < l) (tree-sort < l)))) - -(define-test-case bbtrees bbtree-union - (let ([empty (make-bbtree charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) - charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) - charlist "abcdefghijlmnopqrstuvwxyz")] - [b1 (map (lambda (x) (cons x (char->integer x))) l)] - [b2 (map (lambda (x) (cons x #f)) l)]) - (test-equal b1 - (bbtree->alist (bbtree-union (alist->bbtree b1 charbbtree b2 charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) - charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) - charalist (bbtree-intersection bbtree1 bbtree2))) - ;; check this holds on larger bbtrees - (let* ([l (string->list "abcdefghijlmnopqrstuvwxyz")] - [b1 (map (lambda (x) (cons x (char->integer x))) l)] - [b2 (map (lambda (x) (cons x #f)) l)]) - (test-equal b1 - (bbtree->alist (bbtree-intersection (alist->bbtree b1 charbbtree b2 charalist (bbtree-intersection bbtree1 bbtree2)) - (bbtree->alist - (bbtree-difference bbtree1 - (bbtree-difference bbtree1 bbtree2))))))) - -(define-test-case bbtrees bbtree-difference - (let ([empty (make-bbtree charbbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101)) - charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) - charalist (bbtree-difference bbtree1 bbtree2))) - (test-equal '((#\p . 12) (#\s . 15)) - (bbtree->alist (bbtree-difference bbtree2 bbtree1)))))) - -(define-test-case bbtrees bbtree-indexing - (let* ([l (string->list "abcdefghijklmno")] - [bb (alist->bbtree (map (lambda (x) (cons x #f)) l) charlist (list->deque list)))) - (l1 '()) - (l2 '(1 2 3)) - (l3 '(4 5 6 7 8 9 10)) - (l4 (string->list "abcdefghijklmnopqrstuvwxyz"))) - (test-equal l1 (id-list l1)) - (test-equal l2 (id-list l2)) - (test-equal l3 (id-list l3)) - (test-equal l4 (id-list l4)))) - -) diff --git a/tests/fingertrees.sls b/tests/fingertrees.sls deleted file mode 100644 index 0586350..0000000 --- a/tests/fingertrees.sls +++ /dev/null @@ -1,181 +0,0 @@ -#!r6rs -(library (pfds tests fingertrees) -(export fingertrees) -(import (rnrs) - (wak trc-testing) - (pfds tests utils) - (rename (pfds fingertrees) - (make-fingertree %make-fingertree) - (list->fingertree %list->fingertree)) - ) - -;; Right now, I am not testing the monoidal parts of fingertrees, so -;; we use constructor that replaces these with arbitrary values -(define (make-fingertree) - (%make-fingertree 0 (lambda (x y) x) (lambda (x) x))) - -(define (list->fingertree l) - (%list->fingertree l 0 (lambda (x y) x) (lambda (x) x))) - -(define (list->product-tree l) - (%list->fingertree l 1 * values)) - -(define (list->last-tree l) - (define *cookie* (cons 'no 'last)) - (define (pick x y) - (if (eq? *cookie* y) - x - y)) - (%list->fingertree l *cookie* pick values)) - -(define-test-suite fingertrees - "Tests for the fingertree implementation") - -(define-test-case fingertrees empty-tree () - (test-predicate fingertree? (make-fingertree)) - (test-predicate fingertree-empty? (make-fingertree))) - -(define-test-case fingertrees construction - (let ((l1 '(a b c d e f)) - (l2 '((#t . f) (#t . e) (#t . d) (#t . c) (#t . b) (#t . a))) - (l3 '((#f . a) (#f . b) (#f . c) (#f . d) (#f . e) (#f . f))) - (l4 '((#f . b) (#f . c) (#t . a) (#f . d) (#f . e) (#f . f))) - (l5 '((#f . e) (#t . d) (#t . c) (#t . b) (#f . f) (#t . a))) - (make (lambda (alist) - (fold-left (lambda (tree pair) - (if (car pair) - (fingertree-cons (cdr pair) tree) - (fingertree-snoc tree (cdr pair)))) - (make-fingertree) - alist))) - (empty (make-fingertree))) - (test-case construction () - (test-eqv #f (fingertree-empty? (fingertree-cons #f empty))) - (test-eqv #f (fingertree-empty? (fingertree-snoc empty #f))) - (test-equal l1 (fingertree->list (make l2))) - (test-equal l1 (fingertree->list (make l3))) - (test-equal l1 (fingertree->list (make l4))) - (test-equal l1 (fingertree->list (make l5)))))) - -(define-test-case fingertrees removal - (let* ((l1 '(a b c d e f)) - (f1 (list->fingertree l1)) - (f2 (make-fingertree))) - (test-case removal () - (test-exn fingertree-empty-condition? (fingertree-uncons f2)) - (test-exn fingertree-empty-condition? (fingertree-unsnoc f2)) - (let-values (((head tail) (fingertree-uncons f1))) - (test-eqv (car l1) head) - (test-equal (cdr l1) (fingertree->list tail))) - (let*-values (((init last) (fingertree-unsnoc f1)) - ((l*) (reverse l1)) - ((l1-last) (car l*)) - ((l1-init) (reverse (cdr l*)))) - (test-eqv l1-last last) - (test-equal l1-init (fingertree->list init)))))) - -(define-test-case fingertrees conversion - (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 - 183 199 254 78 210 14 131 10 220 205 203 125 111 42 249)) - (l2 '(25 168 21 246 39 211 60 83 103 161 192 201 31 253 - 156 218 204 186 155 117))) - (test-case conversion () - (test-equal '() (fingertree->list (list->fingertree '()))) - (test-equal l1 (fingertree->list (list->fingertree l1))) - (test-equal l2 (fingertree->list (list->fingertree l2)))))) - -(define-test-case fingertrees ftree-append - (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 - 183 199 254 78 210 14 131 10 220 205 203 125 111 42 249)) - (l2 '(25 168 21 246 39 211 60 83 103 161 192 201 31 253 - 156 218 204 186 155 117)) - (append* (lambda (a b) - (fingertree->list - (fingertree-append - (list->fingertree a) - (list->fingertree b)))))) - (test-case ftree-append () - (test-equal (append l1 '()) (append* l1 '())) - (test-equal (append '() l1) (append* '() l1)) - (test-equal (append l1 l2) (append* l1 l2)) - (test-equal (append l1 l1) (append* l1 l1)) - (test-equal (append l1 l2) (append* l1 l2))))) - -(define-test-case fingertrees monoidal-operation - (let ((l1 '(31 238 100 129 6 169 239 150 96 141 - 207 208 190 45 56 183 199 254 78 210)) - (l2 '((31 238 100 129 6) (169 239 150) (96 141 207 208 190) - () (45 56 183 199) (254 78 210))) - (car/default (lambda (dflt) (lambda (x) (if (pair? x) (car x) dflt)))) - (list->sum-tree (lambda (l1) (%list->fingertree l1 0 + values)))) - (test-case moniodal-operation () - (test-equal 254 (fingertree-measure (%list->fingertree l1 0 max values))) - (test-equal 6 (fingertree-measure (%list->fingertree l1 1000 min values))) - (test-equal l1 (fingertree-measure (%list->fingertree l2 '() append values))) - (test-equal 595 (fingertree-measure - (%list->fingertree l2 0 + (car/default 0)))) - ;; sum of l1 is 4239 - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 0)) - (list->sum-tree l1)))) - (fingertree->list (fingertree-append a b)))) - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 1000)) - (list->sum-tree l1)))) - (fingertree->list (fingertree-append a b)))) - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 2000)) - (list->sum-tree l1)))) - (fingertree->list (fingertree-append a b)))) - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 5000)) - (list->sum-tree l1)))) - (fingertree->list (fingertree-append a b))))))) - -(define-test-case fingertrees fingertree-folds - (let* ((l '(31 238 100 129 6 169 239 150 96 141 - 207 208 190 45 56 183 199 254 78 210)) - (lrev (reverse l)) - (total (apply + l)) - (ft (list->fingertree l))) - (test-case fingertree-folds () - ;; empty case - (test-eqv #t (fingertree-fold (lambda _ #f) #t (make-fingertree))) - (test-eqv #t (fingertree-fold-right (lambda _ #f) #t (make-fingertree))) - ;; associative operations - (test-eqv total (fingertree-fold + 0 ft)) - (test-eqv total (fingertree-fold-right + 0 ft)) - ;; non-associative operations - (test-equal lrev (fingertree-fold cons '() ft)) - (test-equal l (fingertree-fold-right cons '() ft))))) - -(define-test-case fingertrees reversal - (let ((rev (lambda (l) - (fingertree->list - (fingertree-reverse (list->fingertree l))))) - (id (lambda (l) - (fingertree->list - (fingertree-reverse - (fingertree-reverse (list->fingertree l)))))) - (l1 '(126 6 48 86 2 119 233 92 230 160)) - (l2 '(25 168 21 246 39 211 60 83 103 161 - 192 201 31 253 156 218 204 186 155 117))) - (test-case reversal () - ;; behaves the same as regular reverse on lists - (test-eqv '() (rev '())) - (test-equal '(1) (rev '(1))) - (test-equal '(6 5 4 3 2 1) (rev '(1 2 3 4 5 6))) - (test-equal (reverse l1) (rev l1)) - (test-equal (reverse l2) (rev l2)) - ;; double reversal is the the same list - (test-equal l1 (id l1)) - (test-equal l2 (id l2)) - ;; a fingertree will have the same measure as its reverse if - ;; the monoid is commutative - (test-equal (fingertree-measure (list->product-tree l1)) - (fingertree-measure - (fingertree-reverse (list->product-tree l1)))) - ;; otherwise they are not necessarily the same - ;; in this case, they are the same only if the first and last - ;; elements are the same - (test-not - (equal? (fingertree-measure (list->last-tree l2)) - (fingertree-measure (fingertree-reverse (list->product-tree l2)))))))) - -) diff --git a/tests/hamts.sls b/tests/hamts.sls deleted file mode 100644 index 2fe47ee..0000000 --- a/tests/hamts.sls +++ /dev/null @@ -1,141 +0,0 @@ -#!r6rs -(library (pfds tests hamts) -(export hamts) -(import (rnrs) - (wak trc-testing) - (pfds tests utils) - (pfds hamts)) - -(define (make-string-hamt) - (make-hamt string-hash string=?)) - -(define (compare-string-alist l1 l2) - (lambda (l1 l2) - (define (compare x y) (stringhamt / distinct keys - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) - (h (alist->hamt l string-hash string=?))) - (test-equal (list 1 2 3) - (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) - ;; alist->hamt / overlapping keys (leftmost shadows) - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("a" . 4))) - (h (alist->hamt l string-hash string=?))) - (test-equal (list 1 2 3) - (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) - ;; hamt->alist / distinct keys means left inverse - (let ((l '(("a" . 1) ("b" . 2) ("c" . 3)))) - (test-compare compare-string-alist l - (hamt->alist (alist->hamt l string-hash string=?))))) - -(define-test-case hamts hamt-folding () - ;; count size - (let ((h (alist->hamt '(("a" . 1) ("b" . 2) ("c" . 3)) string-hash string=?)) - (increment (lambda (k v acc) (+ 1 acc)))) - (test-equal 3 (hamt-fold increment 0 h))) - ;; copy hamt - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) - (h (alist->hamt l string-hash string=?)) - (add (lambda (k v acc) (hamt-set acc k v)))) - (test-compare compare-string-alist l - (hamt->alist (hamt-fold add (make-string-hamt) h))))) - -(define-test-case hamts hamt-removal () - ;; removed key exists - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) - (h (alist->hamt l string-hash string=?))) - (test-case key-exists () - (test-compare compare-string-alist '(("b" . 2) ("c" . 3)) (hamt-delete h "a")) - (test-eqv (- (hamt-size h) 1) (hamt-size (hamt-delete h "a"))))) - ;; removed key does not exist - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) - (h (alist->hamt l string-hash string=?))) - (test-case key-not-exists () - (test-compare compare-string-alist l (hamt-delete h "d")) - (test-eqv (hamt-size h) (hamt-size (hamt-delete h "d")))))) - -(define-test-case hamts hamt-updates () - ;; update non-existent key - (test-eqv 1 (hamt-ref (hamt-update (make-string-hamt) "foo" add1 0) "foo" #f)) - ;; update existing key - (let ((h (hamt-set (make-string-hamt) "foo" 12))) - (test-eqv 13 (hamt-ref (hamt-update h "foo" add1 0) "foo" #f)))) - -(define-test-case hamts hamt-collisions () - ;; a bad hash function does not cause problems - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) - (h (alist->hamt l bad-hash string=?))) - (test-compare compare-string-alist l (hamt->alist h))) - ;; stress test, since bigger amounts data usually finds bugs - (let ((insert (lambda (val hamt) (hamt-set hamt val val))) - (hash (lambda (n) (exact (floor (/ n 2)))))) - (test-eqv 100 (hamt-size (foldl insert (make-hamt hash =) (iota 100))))) - ;; collision removal - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4))) - (h (alist->hamt l bad-hash string=?))) - (test-compare compare-string-alist '() - (foldl (lambda (str hamt) (hamt-delete hamt str)) - h - '("b" "notexists" "d" "a" "c" "notexists")))) - ;; stress test removal - (let* ((al (map (lambda (x) (cons x #t)) (iota 100))) - (hash (lambda (n) (exact (floor (/ n 2))))) - (h (alist->hamt al hash =))) - (test-eqv 94 (hamt-size (foldl (lambda (s h) (hamt-delete h s)) - h - (list 1 93 72 6 24 48))))) - ;; collision updates - (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) - (h (alist->hamt l bad-hash string=?))) - (test-compare compare-string-alist - '(("a" . 2) ("b" . 3) ("c" . 4)) - (foldl (lambda (key hamt) - (hamt-update hamt key add1 0)) - h - '("a" "b" "c"))))) - -(define-test-case hamts hamt-mapping () - (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) - (h (alist->hamt l string-hash string=?))) - (test-compare compare-string-alist l - (hamt->alist (hamt-map (lambda (x) x) h)))) - (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) - (h (alist->hamt l string-hash string=?)) - (stringify (lambda (n) (string (integer->char n))))) - (test-compare compare-string-alist - '(("a". "a") ("b" . "b") ("c" . "c")) - (hamt->alist (hamt-map stringify h)))) - (let ((h (alist->hamt '(("a" . 97) ("b" . 98) ("c" . 99)) string-hash string=?))) - (test-eqv (hamt-size h) (hamt-size (hamt-map (lambda (x) x) h))))) - -) diff --git a/tests/heaps.sls b/tests/heaps.sls deleted file mode 100644 index 7b601b0..0000000 --- a/tests/heaps.sls +++ /dev/null @@ -1,71 +0,0 @@ -#!r6rs -(library (pfds tests heaps) -(export heaps) -(import (rnrs) - (wak trc-testing) - (pfds tests utils) - (pfds heaps)) - -(define-test-suite heaps - "Tests for the leftist heap implementation") - -(define-test-case heaps empty-heap () - (test-predicate heap? (make-heap <)) - (test-predicate heap-empty? (make-heap <)) - (test-eqv 0 (heap-size (heap <))) - ) - -(define-test-case heaps heap-insertion - (let ((h1 (heap < 7 1 13 9 5 3 11)) - (h2 (heap < 4 2 8 10 6 0 12))) - (test-case heap-insertion () - (test-equal (+ 1 (heap-size h1)) - (heap-size (heap-insert h1 0))) - (test-equal (+ 1 (heap-size h1)) - (heap-size (heap-insert h1 1))) - (test-equal '(1 2 3 5 7 9 11 13) - (heap->list (heap-insert h1 2))) - (test-equal '(1 3 4 5 7 9 11 13) - (heap->list (heap-insert h1 4))) - (test-equal '(1 3 5 7 9 11 12 13) - (heap->list (heap-insert h1 12))) - (test-equal '(1 3 5 7 9 11 13 100) - (heap->list (heap-insert h1 100))) - (test-equal '(-2 0 2 4 6 8 10 12) - (heap->list (heap-insert h2 -2))) - (test-equal '(0 0 2 4 6 8 10 12) - (heap->list (heap-insert h2 0))) - (test-equal '(0 2 4 6 8 8 10 12) - (heap->list (heap-insert h2 8)))))) - -(define-test-case heaps heap-deletion - (let ((h1 (heap < 7 1 13 9 5 3 11)) - (h2 (heap < 4 2 8 6 0))) - (test-case heap-deletion () - (test-equal (- (heap-size h1) 1) - (heap-size (heap-delete-min h1))) - (test-equal 1 (heap-min h1)) - (test-equal 0 (heap-min h2)) - (test-equal 1 (heap-min (heap-delete-min (heap-insert h1 -10)))) - (test-equal 3 (heap-size (heap-delete-min (heap-delete-min h2)))) - (test-equal 4 (heap-min (heap-delete-min (heap-delete-min h2)))) - (test-equal '(7 9 11 13) - (heap->list - (heap-delete-min (heap-delete-min (heap-delete-min h1))))) - (test-exn heap-empty-condition? (heap-pop (make-heap <))) - (test-exn heap-empty-condition? (heap-delete-min (make-heap <))) - (test-exn heap-empty-condition? (heap-min (make-heap <)))))) - -(define-test-case heaps sorting - (let ((l1 '(129 109 146 175 229 48 225 239 129 41 - 38 13 187 15 207 70 64 198 79 125)) - (l2 '(72 17 220 158 164 133 20 78 96 230 25 - 19 13 17 58 223 37 214 94 195 93 174))) - (test-case sorting () - (test-equal '() (heap-sort < '())) - (test-equal (list-sort < l1) - (heap-sort < l1)) - (test-equal (list-sort < l2) - (heap-sort < l2))))) - -) diff --git a/tests/psqs.sls b/tests/psqs.sls deleted file mode 100644 index bdc2e02..0000000 --- a/tests/psqs.sls +++ /dev/null @@ -1,144 +0,0 @@ -#!r6rs -(library (pfds tests psqs) -(export psqs) -(import (rnrs) - (wak trc-testing) - (pfds tests utils) - (pfds psqs)) - -(define (alist->psq alist keypsq '((#\a . 10) (#\b . 33) (#\c . 3)) - charpsq '((#\a . 10) (#\b . 33) (#\c . 3) (#\d . 23) (#\e . 7)) - charpsq alist charqueue list))) - (test-eqv 5 (queue-length queue)) - (test-equal list (queue->list queue)))) - -) diff --git a/tests/sequences.sls b/tests/sequences.sls deleted file mode 100644 index 1da1bc9..0000000 --- a/tests/sequences.sls +++ /dev/null @@ -1,23 +0,0 @@ -#!r6rs -(library (pfds tests sequences) -(export sequences) -(import (rnrs) - (wak trc-testing) - (pfds tests utils) - (pfds sequences)) - -(define-test-suite sequences - "Tests for the sequences implementation") -;; Note: at the moment, sequences are a trivial instantiation of -;; fingertrees, and so are pretty much covered by the fingertrees -;; tests. - -(define-test-case sequences sequences-bugs - (let ((s (sequence 'zero 'one 'two))) - (test-case sequences-bugs () - (test-eqv 'zero (sequence-ref s 0)) - (test-eqv 'two (sequence-ref s 2)) - (test-exn assertion-violation? (sequence-ref s -1)) - (test-exn assertion-violation? (sequence-ref s 3))))) - -) diff --git a/tests/sets.sls b/tests/sets.sls deleted file mode 100644 index e2d3b90..0000000 --- a/tests/sets.sls +++ /dev/null @@ -1,94 +0,0 @@ -#!r6rs -(library (pfds tests sets) -(export sets) -(import (rnrs) - (wak trc-testing) - (pfds tests utils) - (pfds sets)) - -(define-test-suite sets - "Tests for the set implementation") - -(define-test-case sets set-basics - (let ([empty (make-set stringset '("foo" "bar" "baz") stringset '("foo" "bar" "baz" "quux" "zot") stringset '(0 2 5 7 12 2 3 62 5) <)] - [set2 (list->set '(94 33 44 2 73 55 48 92 98 29 - 28 98 55 20 69 5 33 53 89 50) - <)] - [sets (list empty set1 set2)]) - (test-case set-operations () - (test (for-all (lambda (x) (set=? x (set-union x x))) sets)) - (test (for-all (lambda (x) (set=? x (set-intersection x x))) sets)) - (test (for-all (lambda (x) (set=? empty (set-difference x x))) sets)) - (test (for-all (lambda (x) (set=? x (set-union empty x))) sets)) - (test (for-all (lambda (x) (set=? empty (set-intersection empty x))) sets)) - (test (for-all (lambda (x) (set=? x (set-difference x empty))) sets)) - (test (for-all (lambda (x) (set=? empty (set-difference empty x))) sets)) - - (test (set=? (set-union set1 set2) (set-union set2 set1))) - (test (set=? (set-union set1 set2) - (list->set '(0 2 3 69 7 73 12 20 89 28 - 29 94 5 33 98 92 44 48 50 53 - 55 62) - <))) - - (test (set=? (set-intersection set1 set2) (set-intersection set2 set1))) - (test (set=? (set-intersection set1 set2) - (list->set '(2 5) <))) - (test (set=? (set-difference set1 set2) - (list->set '(0 3 12 62 7) <))) - (test (set=? (set-difference set2 set1) - (list->set '(33 98 69 73 44 48 92 50 20 53 - 55 89 28 29 94) - <)))))) - -(define-test-case sets set-conversion () - (test-eqv '() (set->list (make-set <))) - (test-eqv 0 (set-size (list->set '() <))) - (test-equal (string->list "abcdefghijklmno") - (list-sort charlist - (list->set (string->list "abcdefghijklmno") charlist (fold-left set-insert (make-set <) '(0 0 0 0))))) - -(define-test-case sets set-iterators () - (test-eqv 0 (set-fold + 0 (list->set '() <))) - (test-eqv 84 (set-fold + 0 (list->set '(3 12 62 7) <))) - (test-eqv 499968 (set-fold * 1 (list->set '(3 12 62 7 8 4) <)))) - -) diff --git a/tests/utils.sls b/tests/utils.sls deleted file mode 100644 index 0cbe179..0000000 --- a/tests/utils.sls +++ /dev/null @@ -1,61 +0,0 @@ -#!r6rs -(library (pfds tests utils) -(export pfds - test - test-not - test-exn - test-no-exn - add1 - foldl - iota - ) -(import (rnrs) - (wak trc-testing)) - -(define-test-suite pfds - "Test suite for libraries under the (pfds) namespace") - -(define-syntax test - (syntax-rules () - ((test body) - (test-eqv #t (and body #t))))) - -(define-syntax test-not - (syntax-rules () - ((test-not body) - (test-eqv #f body)))) - -(define-syntax test-exn - (syntax-rules () - ((test-exn exception-pred? body) - (test-eqv #t - (guard (exn ((exception-pred? exn) #t) - (else #f)) - body - #f))))) - -(define-syntax test-no-exn - (syntax-rules () - ((test-no-exn body) - (test-eqv #t - (guard (exn (else #f)) - body - #t))))) - -(define (add1 x) - (+ x 1)) - -(define (foldl kons knil list) - (if (null? list) - knil - (foldl kons (kons (car list) knil) (cdr list)))) - -(define (iota n) - (define (recur x) - (if (< x n) - (cons x (recur (+ x 1))) - '())) - (assert (integer? n)) - (recur 0)) - -) From 9755ffc2c59df2a303aa5f0885ecfefae2c67097 Mon Sep 17 00:00:00 2001 From: Johan Hidding Date: Thu, 28 Dec 2017 20:02:15 +0100 Subject: [PATCH 4/4] rename assertions --- test/bbtrees.scm | 125 ++++++++++++++++++++++--------------------- test/deques.scm | 71 ++++++++++++------------ test/fingertrees.scm | 91 +++++++++++++++---------------- test/hamts.scm | 59 ++++++++++---------- test/heaps.scm | 51 +++++++++--------- test/psqs.scm | 109 ++++++++++++++++++------------------- test/queues.scm | 35 ++++++------ test/sequences.scm | 9 ++-- test/sets.scm | 41 +++++++------- test/test-pfds.scm | 26 --------- 10 files changed, 300 insertions(+), 317 deletions(-) delete mode 100644 test/test-pfds.scm diff --git a/test/bbtrees.scm b/test/bbtrees.scm index a4d5786..d558913 100644 --- a/test/bbtrees.scm +++ b/test/bbtrees.scm @@ -2,6 +2,7 @@ (export bbtrees) (import (rnrs (6)) (chez-test suite) + (chez-test assertions) (test utils) (pfds bbtrees)) @@ -10,31 +11,31 @@ "Tests for the bounded balance tree imlementation") (define-test-case bbtrees empty-tree () - (test-predicate bbtree? (make-bbtree <)) - (test-eqv 0 (bbtree-size (make-bbtree <)))) + (assert-predicate bbtree? (make-bbtree <)) + (assert-eqv 0 (bbtree-size (make-bbtree <)))) (define-test-case bbtrees bbtree-set () (let* ([tree1 (bbtree-set (make-bbtree <) 1 'a)] [tree2 (bbtree-set tree1 2 'b)] [tree3 (bbtree-set tree2 1 'c )]) - (test-eqv 1 (bbtree-size tree1)) - (test-eqv 'a (bbtree-ref tree1 1)) - (test-eqv 2 (bbtree-size tree2)) - (test-eqv 'b (bbtree-ref tree2 2)) - (test-eqv 2 (bbtree-size tree3)) - (test-eqv 'c (bbtree-ref tree3 1)) - (test-eqv #f (bbtree-ref tree1 #xdeadbeef #f)) - (test-eqv 'not-in (bbtree-ref tree1 #xdeadbeef 'not-in)) - (test-exn assertion-violation? (bbtree-ref tree3 20)))) + (assert-eqv 1 (bbtree-size tree1)) + (assert-eqv 'a (bbtree-ref tree1 1)) + (assert-eqv 2 (bbtree-size tree2)) + (assert-eqv 'b (bbtree-ref tree2 2)) + (assert-eqv 2 (bbtree-size tree3)) + (assert-eqv 'c (bbtree-ref tree3 1)) + (assert-eqv #f (bbtree-ref tree1 #xdeadbeef #f)) + (assert-eqv 'not-in (bbtree-ref tree1 #xdeadbeef 'not-in)) + (assert-raises assertion-violation? (bbtree-ref tree3 20)))) (define-test-case bbtrees bbtree-update () (let ([bb (alist->bbtree '(("foo" . 10) ("bar" . 12)) stringbbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) string))) - (test-eqv #t (bbtree-fold-right (lambda args #f) #t (make-bbtree >))) + (assert-eqv #t (bbtree-fold (lambda args #f) #t (make-bbtree >))) + (assert-eqv #t (bbtree-fold-right (lambda args #f) #t (make-bbtree >))) ;; associative operations - (test-eqv 20 (bbtree-fold (lambda (key value accum) (+ value accum)) 0 bb)) - (test-eqv 20 (bbtree-fold-right (lambda (key value accum) (+ value accum)) 0 bb)) + (assert-eqv 20 (bbtree-fold (lambda (key value accum) (+ value accum)) 0 bb)) + (assert-eqv 20 (bbtree-fold-right (lambda (key value accum) (+ value accum)) 0 bb)) ;; non-associative operations - (test-equal '("foo" "baz" "bar") + (assert-equal '("foo" "baz" "bar") (bbtree-fold (lambda (key value accum) (cons key accum)) '() bb)) - (test-equal '("bar" "baz" "foo") + (assert-equal '("bar" "baz" "foo") (bbtree-fold-right (lambda (key value accum) (cons key accum)) '() bb))))) (define-test-case bbtrees bbtree-map @@ -74,16 +75,16 @@ (bb (alist->bbtree '((#\a . foo) (#\b . bar) (#\c . baz) (#\d . quux)) charalist (bbtree-map (lambda (x) (cons x x)) bb))) - (test-equal '((#\a . "foo") (#\b . "bar") (#\c . "baz") (#\d . "quux")) + (assert-equal '((#\a . "foo") (#\b . "bar") (#\c . "baz") (#\d . "quux")) (bbtree->alist (bbtree-map symbol->string bb)))))) (define-test-case bbtrees conversion () - (test-eqv '() (bbtree->alist (make-bbtree <))) - (test-eqv 0 (bbtree-size (alist->bbtree '() <))) - (test-equal '(("bar" . 12) ("baz" . 7) ("foo" . 1)) + (assert-eqv '() (bbtree->alist (make-bbtree <))) + (assert-eqv 0 (bbtree-size (alist->bbtree '() <))) + (assert-equal '(("bar" . 12) ("baz" . 7) ("foo" . 1)) (bbtree->alist (alist->bbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) stringbbtree (map (lambda (x) (cons x 'dummy)) l) <)))))) - (test-equal (list-sort < l) (tree-sort < l)))) + (assert-equal (list-sort < l) (tree-sort < l)))) (define-test-case bbtrees bbtree-union (let ([empty (make-bbtree charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) charlist "abcdefghijlmnopqrstuvwxyz")] [b1 (map (lambda (x) (cons x (char->integer x))) l)] [b2 (map (lambda (x) (cons x #f)) l)]) - (test-equal b1 + (assert-equal b1 (bbtree->alist (bbtree-union (alist->bbtree b1 charbbtree b2 charbbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) charalist (bbtree-intersection bbtree1 bbtree2))) ;; check this holds on larger bbtrees (let* ([l (string->list "abcdefghijlmnopqrstuvwxyz")] [b1 (map (lambda (x) (cons x (char->integer x))) l)] [b2 (map (lambda (x) (cons x #f)) l)]) - (test-equal b1 + (assert-equal b1 (bbtree->alist (bbtree-intersection (alist->bbtree b1 charbbtree b2 charalist (bbtree-intersection bbtree1 bbtree2)) + (assert-equal (bbtree->alist (bbtree-intersection bbtree1 bbtree2)) (bbtree->alist (bbtree-difference bbtree1 (bbtree-difference bbtree1 bbtree2))))))) @@ -157,13 +158,13 @@ [bbtree2 (alist->bbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12)) charalist (bbtree-difference bbtree1 bbtree2))) - (test-equal '((#\p . 12) (#\s . 15)) + (assert-equal '((#\p . 12) (#\s . 15)) (bbtree->alist (bbtree-difference bbtree2 bbtree1)))))) (define-test-case bbtrees bbtree-indexing @@ -171,15 +172,15 @@ [bb (alist->bbtree (map (lambda (x) (cons x #f)) l) charlist "abcdefghijklmnopqrstuvwxyz"))) - (test-equal l1 (id-list l1)) - (test-equal l2 (id-list l2)) - (test-equal l3 (id-list l3)) - (test-equal l4 (id-list l4)))) + (assert-equal l1 (id-list l1)) + (assert-equal l2 (id-list l2)) + (assert-equal l3 (id-list l3)) + (assert-equal l4 (id-list l4)))) ) diff --git a/test/fingertrees.scm b/test/fingertrees.scm index acc9c57..71b9661 100644 --- a/test/fingertrees.scm +++ b/test/fingertrees.scm @@ -2,6 +2,7 @@ (export fingertrees) (import (rnrs (6)) (chez-test suite) + (chez-test assertions) (test utils) (rename (pfds fingertrees) (make-fingertree %make-fingertree) @@ -31,8 +32,8 @@ "Tests for the fingertree implementation") (define-test-case fingertrees empty-tree () - (test-predicate fingertree? (make-fingertree)) - (test-predicate fingertree-empty? (make-fingertree))) + (assert-predicate fingertree? (make-fingertree)) + (assert-predicate fingertree-empty? (make-fingertree))) (define-test-case fingertrees construction (let ((l1 '(a b c d e f)) @@ -49,29 +50,29 @@ alist))) (empty (make-fingertree))) (test-case construction () - (test-eqv #f (fingertree-empty? (fingertree-cons #f empty))) - (test-eqv #f (fingertree-empty? (fingertree-snoc empty #f))) - (test-equal l1 (fingertree->list (make l2))) - (test-equal l1 (fingertree->list (make l3))) - (test-equal l1 (fingertree->list (make l4))) - (test-equal l1 (fingertree->list (make l5)))))) + (assert-eqv #f (fingertree-empty? (fingertree-cons #f empty))) + (assert-eqv #f (fingertree-empty? (fingertree-snoc empty #f))) + (assert-equal l1 (fingertree->list (make l2))) + (assert-equal l1 (fingertree->list (make l3))) + (assert-equal l1 (fingertree->list (make l4))) + (assert-equal l1 (fingertree->list (make l5)))))) (define-test-case fingertrees removal (let* ((l1 '(a b c d e f)) (f1 (list->fingertree l1)) (f2 (make-fingertree))) (test-case removal () - (test-exn fingertree-empty-condition? (fingertree-uncons f2)) - (test-exn fingertree-empty-condition? (fingertree-unsnoc f2)) + (assert-raises fingertree-empty-condition? (fingertree-uncons f2)) + (assert-raises fingertree-empty-condition? (fingertree-unsnoc f2)) (let-values (((head tail) (fingertree-uncons f1))) - (test-eqv (car l1) head) - (test-equal (cdr l1) (fingertree->list tail))) + (assert-eqv (car l1) head) + (assert-equal (cdr l1) (fingertree->list tail))) (let*-values (((init last) (fingertree-unsnoc f1)) ((l*) (reverse l1)) ((l1-last) (car l*)) ((l1-init) (reverse (cdr l*)))) - (test-eqv l1-last last) - (test-equal l1-init (fingertree->list init)))))) + (assert-eqv l1-last last) + (assert-equal l1-init (fingertree->list init)))))) (define-test-case fingertrees conversion (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 @@ -79,9 +80,9 @@ (l2 '(25 168 21 246 39 211 60 83 103 161 192 201 31 253 156 218 204 186 155 117))) (test-case conversion () - (test-equal '() (fingertree->list (list->fingertree '()))) - (test-equal l1 (fingertree->list (list->fingertree l1))) - (test-equal l2 (fingertree->list (list->fingertree l2)))))) + (assert-equal '() (fingertree->list (list->fingertree '()))) + (assert-equal l1 (fingertree->list (list->fingertree l1))) + (assert-equal l2 (fingertree->list (list->fingertree l2)))))) (define-test-case fingertrees ftree-append (let ((l1 '(31 238 100 129 6 169 239 150 96 141 207 208 190 45 56 @@ -94,11 +95,11 @@ (list->fingertree a) (list->fingertree b)))))) (test-case ftree-append () - (test-equal (append l1 '()) (append* l1 '())) - (test-equal (append '() l1) (append* '() l1)) - (test-equal (append l1 l2) (append* l1 l2)) - (test-equal (append l1 l1) (append* l1 l1)) - (test-equal (append l1 l2) (append* l1 l2))))) + (assert-equal (append l1 '()) (append* l1 '())) + (assert-equal (append '() l1) (append* '() l1)) + (assert-equal (append l1 l2) (append* l1 l2)) + (assert-equal (append l1 l1) (append* l1 l1)) + (assert-equal (append l1 l2) (append* l1 l2))))) (define-test-case fingertrees monoidal-operation (let ((l1 '(31 238 100 129 6 169 239 150 96 141 @@ -108,22 +109,22 @@ (car/default (lambda (dflt) (lambda (x) (if (pair? x) (car x) dflt)))) (list->sum-tree (lambda (l1) (%list->fingertree l1 0 + values)))) (test-case moniodal-operation () - (test-equal 254 (fingertree-measure (%list->fingertree l1 0 max values))) - (test-equal 6 (fingertree-measure (%list->fingertree l1 1000 min values))) - (test-equal l1 (fingertree-measure (%list->fingertree l2 '() append values))) - (test-equal 595 (fingertree-measure + (assert-equal 254 (fingertree-measure (%list->fingertree l1 0 max values))) + (assert-equal 6 (fingertree-measure (%list->fingertree l1 1000 min values))) + (assert-equal l1 (fingertree-measure (%list->fingertree l2 '() append values))) + (assert-equal 595 (fingertree-measure (%list->fingertree l2 0 + (car/default 0)))) ;; sum of l1 is 4239 - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 0)) + (assert-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 0)) (list->sum-tree l1)))) (fingertree->list (fingertree-append a b)))) - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 1000)) + (assert-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 1000)) (list->sum-tree l1)))) (fingertree->list (fingertree-append a b)))) - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 2000)) + (assert-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 2000)) (list->sum-tree l1)))) (fingertree->list (fingertree-append a b)))) - (test-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 5000)) + (assert-equal l1 (let-values (((a b) (fingertree-split (lambda (x) (> x 5000)) (list->sum-tree l1)))) (fingertree->list (fingertree-append a b))))))) @@ -135,14 +136,14 @@ (ft (list->fingertree l))) (test-case fingertree-folds () ;; empty case - (test-eqv #t (fingertree-fold (lambda _ #f) #t (make-fingertree))) - (test-eqv #t (fingertree-fold-right (lambda _ #f) #t (make-fingertree))) + (assert-eqv #t (fingertree-fold (lambda _ #f) #t (make-fingertree))) + (assert-eqv #t (fingertree-fold-right (lambda _ #f) #t (make-fingertree))) ;; associative operations - (test-eqv total (fingertree-fold + 0 ft)) - (test-eqv total (fingertree-fold-right + 0 ft)) + (assert-eqv total (fingertree-fold + 0 ft)) + (assert-eqv total (fingertree-fold-right + 0 ft)) ;; non-associative operations - (test-equal lrev (fingertree-fold cons '() ft)) - (test-equal l (fingertree-fold-right cons '() ft))))) + (assert-equal lrev (fingertree-fold cons '() ft)) + (assert-equal l (fingertree-fold-right cons '() ft))))) (define-test-case fingertrees reversal (let ((rev (lambda (l) @@ -157,23 +158,23 @@ 192 201 31 253 156 218 204 186 155 117))) (test-case reversal () ;; behaves the same as regular reverse on lists - (test-eqv '() (rev '())) - (test-equal '(1) (rev '(1))) - (test-equal '(6 5 4 3 2 1) (rev '(1 2 3 4 5 6))) - (test-equal (reverse l1) (rev l1)) - (test-equal (reverse l2) (rev l2)) + (assert-eqv '() (rev '())) + (assert-equal '(1) (rev '(1))) + (assert-equal '(6 5 4 3 2 1) (rev '(1 2 3 4 5 6))) + (assert-equal (reverse l1) (rev l1)) + (assert-equal (reverse l2) (rev l2)) ;; double reversal is the the same list - (test-equal l1 (id l1)) - (test-equal l2 (id l2)) + (assert-equal l1 (id l1)) + (assert-equal l2 (id l2)) ;; a fingertree will have the same measure as its reverse if ;; the monoid is commutative - (test-equal (fingertree-measure (list->product-tree l1)) + (assert-equal (fingertree-measure (list->product-tree l1)) (fingertree-measure (fingertree-reverse (list->product-tree l1)))) ;; otherwise they are not necessarily the same ;; in this case, they are the same only if the first and last ;; elements are the same - (test-not + (assert-not (equal? (fingertree-measure (list->last-tree l2)) (fingertree-measure (fingertree-reverse (list->product-tree l2)))))))) diff --git a/test/hamts.scm b/test/hamts.scm index a4e68a5..da429df 100644 --- a/test/hamts.scm +++ b/test/hamts.scm @@ -2,6 +2,7 @@ (export hamts) (import (rnrs (6)) (chez-test suite) + (chez-test assertions) (test utils) (pfds hamts)) @@ -20,53 +21,53 @@ "Tests for the Hash Array Mapped Trie implementation") (define-test-case hamts empty-hamt () - (test-predicate hamt? (make-string-hamt)) - (test-eqv 0 (hamt-size (make-string-hamt)))) + (assert-predicate hamt? (make-string-hamt)) + (assert-eqv 0 (hamt-size (make-string-hamt)))) (define-test-case hamts hamt-ref/set () ;; Referencing non-existent key - (test-equal #f (hamt-ref (make-string-hamt) "foo" #f)) + (assert-equal #f (hamt-ref (make-string-hamt) "foo" #f)) ;; Referencing a non-existent key (exception) - (test-exn assertion-violation? (hamt-ref (make-string-hamt) "bar")) + (assert-raises assertion-violation? (hamt-ref (make-string-hamt) "bar")) ;; Referencing newly-added key - (test-equal "bar" (hamt-ref (hamt-set (make-string-hamt) "foo" "bar") "foo" #f)) - (test-eqv 1 (hamt-size (hamt-set (make-string-hamt) "foo" "bar"))) + (assert-equal "bar" (hamt-ref (hamt-set (make-string-hamt) "foo" "bar") "foo" #f)) + (assert-eqv 1 (hamt-size (hamt-set (make-string-hamt) "foo" "bar"))) ;; shadowing an existing key - (test-equal "baz" (hamt-ref (hamt-set (hamt-set (make-string-hamt) "foo" "bar") "foo" "baz") "foo" #f)) - (test-eqv 1 (hamt-size (hamt-set (hamt-set (make-string-hamt) "foo" "bar") "foo" "baz")))) + (assert-equal "baz" (hamt-ref (hamt-set (hamt-set (make-string-hamt) "foo" "bar") "foo" "baz") "foo" #f)) + (assert-eqv 1 (hamt-size (hamt-set (hamt-set (make-string-hamt) "foo" "bar") "foo" "baz")))) (define-test-case hamts hamt-contains () (let ((h (hamt-set (make-string-hamt) "foo" 1))) - (test-eqv #t (hamt-contains? h "foo"))) + (assert-eqv #t (hamt-contains? h "foo"))) (let ((h (hamt-set (make-string-hamt) "foo" 1))) - (test-eqv #f (hamt-contains? h "bar")))) + (assert-eqv #f (hamt-contains? h "bar")))) (define-test-case hamts hamt-conversion () ;; alist->hamt / distinct keys (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) (h (alist->hamt l string-hash string=?))) - (test-equal (list 1 2 3) + (assert-equal (list 1 2 3) (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) ;; alist->hamt / overlapping keys (leftmost shadows) (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("a" . 4))) (h (alist->hamt l string-hash string=?))) - (test-equal (list 1 2 3) + (assert-equal (list 1 2 3) (map (lambda (x) (hamt-ref h x #f)) (list "a" "b" "c")))) ;; hamt->alist / distinct keys means left inverse (let ((l '(("a" . 1) ("b" . 2) ("c" . 3)))) - (test-compare compare-string-alist l + (assert-compare compare-string-alist l (hamt->alist (alist->hamt l string-hash string=?))))) (define-test-case hamts hamt-folding () ;; count size (let ((h (alist->hamt '(("a" . 1) ("b" . 2) ("c" . 3)) string-hash string=?)) (increment (lambda (k v acc) (+ 1 acc)))) - (test-equal 3 (hamt-fold increment 0 h))) + (assert-equal 3 (hamt-fold increment 0 h))) ;; copy hamt (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) (h (alist->hamt l string-hash string=?)) (add (lambda (k v acc) (hamt-set acc k v)))) - (test-compare compare-string-alist l + (assert-compare compare-string-alist l (hamt->alist (hamt-fold add (make-string-hamt) h))))) (define-test-case hamts hamt-removal () @@ -74,35 +75,35 @@ (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) (h (alist->hamt l string-hash string=?))) (test-case key-exists () - (test-compare compare-string-alist '(("b" . 2) ("c" . 3)) (hamt-delete h "a")) - (test-eqv (- (hamt-size h) 1) (hamt-size (hamt-delete h "a"))))) + (assert-compare compare-string-alist '(("b" . 2) ("c" . 3)) (hamt-delete h "a")) + (assert-eqv (- (hamt-size h) 1) (hamt-size (hamt-delete h "a"))))) ;; removed key does not exist (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) (h (alist->hamt l string-hash string=?))) (test-case key-not-exists () - (test-compare compare-string-alist l (hamt-delete h "d")) - (test-eqv (hamt-size h) (hamt-size (hamt-delete h "d")))))) + (assert-compare compare-string-alist l (hamt-delete h "d")) + (assert-eqv (hamt-size h) (hamt-size (hamt-delete h "d")))))) (define-test-case hamts hamt-updates () ;; update non-existent key - (test-eqv 1 (hamt-ref (hamt-update (make-string-hamt) "foo" add1 0) "foo" #f)) + (assert-eqv 1 (hamt-ref (hamt-update (make-string-hamt) "foo" add1 0) "foo" #f)) ;; update existing key (let ((h (hamt-set (make-string-hamt) "foo" 12))) - (test-eqv 13 (hamt-ref (hamt-update h "foo" add1 0) "foo" #f)))) + (assert-eqv 13 (hamt-ref (hamt-update h "foo" add1 0) "foo" #f)))) (define-test-case hamts hamt-collisions () ;; a bad hash function does not cause problems (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) (h (alist->hamt l bad-hash string=?))) - (test-compare compare-string-alist l (hamt->alist h))) + (assert-compare compare-string-alist l (hamt->alist h))) ;; stress test, since bigger amounts data usually finds bugs (let ((insert (lambda (hamt val) (hamt-set hamt val val))) (hash (lambda (n) (exact (floor (/ n 2)))))) - (test-eqv 100 (hamt-size (fold-left insert (make-hamt hash =) (iota 100))))) + (assert-eqv 100 (hamt-size (fold-left insert (make-hamt hash =) (iota 100))))) ;; collision removal (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4))) (h (alist->hamt l bad-hash string=?))) - (test-compare compare-string-alist '() + (assert-compare compare-string-alist '() (fold-left (lambda (hamt str) (hamt-delete hamt str)) h '("b" "notexists" "d" "a" "c" "notexists")))) @@ -110,13 +111,13 @@ (let* ((al (map (lambda (x) (cons x #t)) (iota 100))) (hash (lambda (n) (exact (floor (/ n 2))))) (h (alist->hamt al hash =))) - (test-eqv 94 (hamt-size (fold-left (lambda (h s) (hamt-delete h s)) + (assert-eqv 94 (hamt-size (fold-left (lambda (h s) (hamt-delete h s)) h (list 1 93 72 6 24 48))))) ;; collision updates (let* ((l '(("a" . 1) ("b" . 2) ("c" . 3))) (h (alist->hamt l bad-hash string=?))) - (test-compare compare-string-alist + (assert-compare compare-string-alist '(("a" . 2) ("b" . 3) ("c" . 4)) (fold-left (lambda (hamt key) (hamt-update hamt key add1 0)) @@ -126,15 +127,15 @@ (define-test-case hamts hamt-mapping () (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) (h (alist->hamt l string-hash string=?))) - (test-compare compare-string-alist l + (assert-compare compare-string-alist l (hamt->alist (hamt-map (lambda (x) x) h)))) (let* ((l '(("a" . 97) ("b" . 98) ("c" . 99))) (h (alist->hamt l string-hash string=?)) (stringify (lambda (n) (string (integer->char n))))) - (test-compare compare-string-alist + (assert-compare compare-string-alist '(("a". "a") ("b" . "b") ("c" . "c")) (hamt->alist (hamt-map stringify h)))) (let ((h (alist->hamt '(("a" . 97) ("b" . 98) ("c" . 99)) string-hash string=?))) - (test-eqv (hamt-size h) (hamt-size (hamt-map (lambda (x) x) h))))) + (assert-eqv (hamt-size h) (hamt-size (hamt-map (lambda (x) x) h))))) ) diff --git a/test/heaps.scm b/test/heaps.scm index cd8cddb..ad9b13d 100644 --- a/test/heaps.scm +++ b/test/heaps.scm @@ -2,6 +2,7 @@ (export heaps) (import (rnrs (6)) (chez-test suite) + (chez-test assertions) (test utils) (pfds heaps)) @@ -9,51 +10,51 @@ "Tests for the leftist heap implementation") (define-test-case heaps empty-heap () - (test-predicate heap? (make-heap <)) - (test-predicate heap-empty? (make-heap <)) - (test-eqv 0 (heap-size (heap <))) + (assert-predicate heap? (make-heap <)) + (assert-predicate heap-empty? (make-heap <)) + (assert-eqv 0 (heap-size (heap <))) ) (define-test-case heaps heap-insertion (let ((h1 (heap < 7 1 13 9 5 3 11)) (h2 (heap < 4 2 8 10 6 0 12))) (test-case heap-insertion () - (test-equal (+ 1 (heap-size h1)) + (assert-equal (+ 1 (heap-size h1)) (heap-size (heap-insert h1 0))) - (test-equal (+ 1 (heap-size h1)) + (assert-equal (+ 1 (heap-size h1)) (heap-size (heap-insert h1 1))) - (test-equal '(1 2 3 5 7 9 11 13) + (assert-equal '(1 2 3 5 7 9 11 13) (heap->list (heap-insert h1 2))) - (test-equal '(1 3 4 5 7 9 11 13) + (assert-equal '(1 3 4 5 7 9 11 13) (heap->list (heap-insert h1 4))) - (test-equal '(1 3 5 7 9 11 12 13) + (assert-equal '(1 3 5 7 9 11 12 13) (heap->list (heap-insert h1 12))) - (test-equal '(1 3 5 7 9 11 13 100) + (assert-equal '(1 3 5 7 9 11 13 100) (heap->list (heap-insert h1 100))) - (test-equal '(-2 0 2 4 6 8 10 12) + (assert-equal '(-2 0 2 4 6 8 10 12) (heap->list (heap-insert h2 -2))) - (test-equal '(0 0 2 4 6 8 10 12) + (assert-equal '(0 0 2 4 6 8 10 12) (heap->list (heap-insert h2 0))) - (test-equal '(0 2 4 6 8 8 10 12) + (assert-equal '(0 2 4 6 8 8 10 12) (heap->list (heap-insert h2 8)))))) (define-test-case heaps heap-deletion (let ((h1 (heap < 7 1 13 9 5 3 11)) (h2 (heap < 4 2 8 6 0))) (test-case heap-deletion () - (test-equal (- (heap-size h1) 1) + (assert-equal (- (heap-size h1) 1) (heap-size (heap-delete-min h1))) - (test-equal 1 (heap-min h1)) - (test-equal 0 (heap-min h2)) - (test-equal 1 (heap-min (heap-delete-min (heap-insert h1 -10)))) - (test-equal 3 (heap-size (heap-delete-min (heap-delete-min h2)))) - (test-equal 4 (heap-min (heap-delete-min (heap-delete-min h2)))) - (test-equal '(7 9 11 13) + (assert-equal 1 (heap-min h1)) + (assert-equal 0 (heap-min h2)) + (assert-equal 1 (heap-min (heap-delete-min (heap-insert h1 -10)))) + (assert-equal 3 (heap-size (heap-delete-min (heap-delete-min h2)))) + (assert-equal 4 (heap-min (heap-delete-min (heap-delete-min h2)))) + (assert-equal '(7 9 11 13) (heap->list (heap-delete-min (heap-delete-min (heap-delete-min h1))))) - (test-exn heap-empty-condition? (heap-pop (make-heap <))) - (test-exn heap-empty-condition? (heap-delete-min (make-heap <))) - (test-exn heap-empty-condition? (heap-min (make-heap <)))))) + (assert-raises heap-empty-condition? (heap-pop (make-heap <))) + (assert-raises heap-empty-condition? (heap-delete-min (make-heap <))) + (assert-raises heap-empty-condition? (heap-min (make-heap <)))))) (define-test-case heaps sorting (let ((l1 '(129 109 146 175 229 48 225 239 129 41 @@ -61,10 +62,10 @@ (l2 '(72 17 220 158 164 133 20 78 96 230 25 19 13 17 58 223 37 214 94 195 93 174))) (test-case sorting () - (test-equal '() (heap-sort < '())) - (test-equal (list-sort < l1) + (assert-equal '() (heap-sort < '())) + (assert-equal (list-sort < l1) (heap-sort < l1)) - (test-equal (list-sort < l2) + (assert-equal (list-sort < l2) (heap-sort < l2))))) ) diff --git a/test/psqs.scm b/test/psqs.scm index e8a4eea..2f66bed 100644 --- a/test/psqs.scm +++ b/test/psqs.scm @@ -2,6 +2,7 @@ (export psqs) (import (rnrs (6)) (chez-test suite) + (chez-test assertions) (test utils) (pfds psqs)) @@ -15,9 +16,9 @@ "Tests for the functional priority search tree implementation") (define-test-case psqs empty-psq () - (test-predicate psq? (make-psq stringpsq '((#\a . 10) (#\b . 33) (#\c . 3)) @@ -54,13 +55,13 @@ (psq4 (psq-delete psq3 #\a)) (psq5 (psq-delete psq1 #\d))) (test-case psq-delete () - (test-eqv #t (psq-contains? psq1 #\c)) - (test-not (psq-contains? psq2 #\c)) - (test-eqv #t (psq-contains? psq2 #\b)) - (test-not (psq-contains? psq3 #\b)) - (test-eqv #t (psq-contains? psq3 #\a)) - (test-predicate psq-empty? psq4) - (test-eqv (psq-size psq1) + (assert-eqv #t (psq-contains? psq1 #\c)) + (assert-not (psq-contains? psq2 #\c)) + (assert-eqv #t (psq-contains? psq2 #\b)) + (assert-not (psq-contains? psq3 #\b)) + (assert-eqv #t (psq-contains? psq3 #\a)) + (assert-predicate psq-empty? psq4) + (assert-eqv (psq-size psq1) (psq-size psq5))))) (define-test-case psqs psq-update @@ -71,19 +72,19 @@ (psq4 (psq-update psq3 #\a add1 0)) (psq5 (psq-update psq3 #\c add1 0))) (test-case psq-update () - (test-eqv 11 (psq-ref psq3 #\a)) - (test-eqv 34 (psq-ref psq3 #\b)) - (test-eqv 4 (psq-ref psq3 #\c)) + (assert-eqv 11 (psq-ref psq3 #\a)) + (assert-eqv 34 (psq-ref psq3 #\b)) + (assert-eqv 4 (psq-ref psq3 #\c)) - (test-eqv 12 (psq-ref psq4 #\a)) - (test-eqv 34 (psq-ref psq4 #\b)) - (test-eqv 4 (psq-ref psq4 #\c)) - (test-eqv 3 (psq-size psq4)) + (assert-eqv 12 (psq-ref psq4 #\a)) + (assert-eqv 34 (psq-ref psq4 #\b)) + (assert-eqv 4 (psq-ref psq4 #\c)) + (assert-eqv 3 (psq-size psq4)) - (test-eqv 11 (psq-ref psq5 #\a)) - (test-eqv 34 (psq-ref psq5 #\b)) - (test-eqv 5 (psq-ref psq5 #\c)) - (test-eqv 3 (psq-size psq5))))) + (assert-eqv 11 (psq-ref psq5 #\a)) + (assert-eqv 34 (psq-ref psq5 #\b)) + (assert-eqv 5 (psq-ref psq5 #\c)) + (assert-eqv 3 (psq-size psq5))))) (define-test-case psqs priority-queue-functions (let* ((psq1 (alist->psq '((#\a . 10) (#\b . 33) (#\c . 3) (#\d . 23) (#\e . 7)) @@ -93,16 +94,16 @@ (psq3 (psq-delete-min (psq-set psq2 #\b 9))) (psq4 (make-psq < <))) (test-case priority-queue-functions () - (test-eqv #\c (psq-min psq1)) - (test-eqv #\e (psq-min psq2)) - (test-exn assertion-violation? (psq-delete-min psq4)) - (test-eqv #\a (psq-min (psq-set psq1 #\a 0))) + (assert-eqv #\c (psq-min psq1)) + (assert-eqv #\e (psq-min psq2)) + (assert-raises assertion-violation? (psq-delete-min psq4)) + (assert-eqv #\a (psq-min (psq-set psq1 #\a 0))) (call-with-values (lambda () (psq-pop psq3)) (lambda (min rest) - (test-eqv #\b min) - (test-eqv #\a (psq-min rest))))))) + (assert-eqv #\b min) + (assert-eqv #\a (psq-min rest))))))) (define-test-case psqs ranged-functions (let* ((alist '((#\f . 24) (#\u . 42) (#\p . 16) (#\s . 34) (#\e . 17) @@ -113,31 +114,31 @@ alist)) (psq (alist->psq alist charqueue list))) - (test-eqv 5 (queue-length queue)) - (test-equal list (queue->list queue)))) + (assert-eqv 5 (queue-length queue)) + (assert-equal list (queue->list queue)))) ) diff --git a/test/sequences.scm b/test/sequences.scm index b9c321c..fc97264 100644 --- a/test/sequences.scm +++ b/test/sequences.scm @@ -2,6 +2,7 @@ (export sequences) (import (rnrs (6)) (chez-test suite) + (chez-test assertions) (test utils) (pfds sequences)) @@ -14,9 +15,9 @@ (define-test-case sequences sequences-bugs (let ((s (sequence 'zero 'one 'two))) (test-case sequences-bugs () - (test-eqv 'zero (sequence-ref s 0)) - (test-eqv 'two (sequence-ref s 2)) - (test-exn assertion-violation? (sequence-ref s -1)) - (test-exn assertion-violation? (sequence-ref s 3))))) + (assert-eqv 'zero (sequence-ref s 0)) + (assert-eqv 'two (sequence-ref s 2)) + (assert-raises assertion-violation? (sequence-ref s -1)) + (assert-raises assertion-violation? (sequence-ref s 3))))) ) diff --git a/test/sets.scm b/test/sets.scm index b8c418e..f4838b2 100644 --- a/test/sets.scm +++ b/test/sets.scm @@ -2,6 +2,7 @@ (export sets) (import (rnrs (6)) (chez-test suite) + (chez-test assertions) (test utils) (pfds sets)) @@ -14,19 +15,19 @@ (make-set stringlist (make-set <))) - (test-eqv 0 (set-size (list->set '() <))) - (test-equal (string->list "abcdefghijklmno") + (assert-eqv '() (set->list (make-set <))) + (assert-eqv 0 (set-size (list->set '() <))) + (assert-equal (string->list "abcdefghijklmno") (list-sort charlist (list->set (string->list "abcdefghijklmno") charlist (fold-left set-insert (make-set <) '(0 0 0 0))))) + (assert-equal '(0) (set->list (fold-left set-insert (make-set <) '(0 0 0 0))))) (define-test-case sets set-iterators () - (test-eqv 0 (set-fold + 0 (list->set '() <))) - (test-eqv 84 (set-fold + 0 (list->set '(3 12 62 7) <))) - (test-eqv 499968 (set-fold * 1 (list->set '(3 12 62 7 8 4) <)))) + (assert-eqv 0 (set-fold + 0 (list->set '() <))) + (assert-eqv 84 (set-fold + 0 (list->set '(3 12 62 7) <))) + (assert-eqv 499968 (set-fold * 1 (list->set '(3 12 62 7 8 4) <)))) ) diff --git a/test/test-pfds.scm b/test/test-pfds.scm deleted file mode 100644 index f91d7a2..0000000 --- a/test/test-pfds.scm +++ /dev/null @@ -1,26 +0,0 @@ -(import (rnrs (6)) - (chez-test suite) - (chez-test reports) - (srfi :48) - (test bbtrees) - (test deques) - (test fingertrees) - (test hamts) - (test heaps) - (test psqs) - (test queues) - (test sequences) - (test sets)) - -(define (test-all) - (format #t "~%") - (print-report (run-suite bbtrees)) - (print-report (run-suite deques)) - (print-report (run-suite fingertrees)) - (print-report (run-suite hamts)) - (print-report (run-suite heaps)) - (print-report (run-suite psqs)) - (print-report (run-suite queues)) - (print-report (run-suite sequences)) - (print-report (run-suite sets)) -)