add chez to runtests

.gitignore

@@ -1,2 +1,2 @@
-compiled/*
-private/compiled/*
+.*.swp
+*~

psqs.sls → lib/pfds/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<? prio<?)
   (when (void? tree)
     (assertion-violation 'psq-pop
@@ -510,6 +517,10 @@
   (assert (psq? psq))
   (min (psq-tree psq)))
 
+(define (psq-min-priority psq)
+  (assert (psq? psq))
+  (min-priority (psq-tree psq)))
+
 (define (psq-delete-min psq)
   (assert (and (psq? psq)
                (not (psq-empty? psq))))

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

test/bbtrees.scm

@@ -0,0 +1,186 @@
+(library (test bbtrees)
+  (export bbtrees)
+  (import (rnrs (6))
+          (chez-test suite)
+          (chez-test assertions)
+
+          (test utils)
+          (pfds bbtrees))
+
+  (define-test-suite bbtrees
+    "Tests for the bounded balance tree imlementation")
+
+  (define-test-case bbtrees empty-tree ()
+    (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 )])
+      (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)) string<?)]
+          [add1 (lambda (x) (+ x 1))])
+      (test-case bbtree-update ()
+        (assert-eqv 11 (bbtree-ref (bbtree-update bb "foo" add1 0) "foo"))
+        (assert-eqv 13 (bbtree-ref (bbtree-update bb "bar" add1 0) "bar"))
+        (assert-eqv  1 (bbtree-ref (bbtree-update bb "baz" add1 0) "baz")))))
+
+  (define-test-case bbtrees bbtree-delete ()
+    (let* ([tree1 (bbtree-set (bbtree-set (bbtree-set (make-bbtree string<?) "a" 3)
+                                          "b"
+                                          8)
+                              "c"
+                              19)]
+           [tree2 (bbtree-delete tree1 "b")]
+           [tree3 (bbtree-delete tree2 "a")])
+      (assert-eqv 3 (bbtree-size tree1))
+      (assert-eqv #t (bbtree-contains? tree1 "b"))
+      (assert-eqv #t (bbtree-contains? tree1 "a"))
+      (assert-eqv 2 (bbtree-size tree2))
+      (assert-eqv #f (bbtree-contains? tree2 "b"))
+      (assert-eqv #t (bbtree-contains? tree2 "a"))
+      (assert-eqv 1 (bbtree-size tree3))
+      (assert-eqv #f (bbtree-contains? tree3 "a"))
+      (assert-no-raise (bbtree-delete (bbtree-delete tree3 "a") "a"))))
+
+  (define-test-case bbtrees bbtree-folds
+    (let ((bb (alist->bbtree '(("foo" . 1) ("bar" . 12) ("baz" . 7)) string<?)))
+      (test-case bbtree-folds ()
+        ;; empty case
+        (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
+        (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
+        (assert-equal '("foo" "baz" "bar")
+                    (bbtree-fold (lambda (key value accum) (cons key accum)) '() bb))
+        (assert-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))
+                             char<?)))
+      (test-case bbtree-map ()
+        (assert-eqv 0 (bbtree-size (bbtree-map (lambda (x) 'foo) empty)))
+        (assert-equal '((#\a foo . foo) (#\b bar . bar) (#\c baz . baz) (#\d quux . quux))
+                    (bbtree->alist (bbtree-map (lambda (x) (cons x x)) bb)))
+        (assert-equal '((#\a . "foo") (#\b . "bar") (#\c . "baz") (#\d . "quux"))
+                    (bbtree->alist (bbtree-map symbol->string bb))))))
+
+  (define-test-case bbtrees conversion ()
+    (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)) string<?)))
+    (let ((l '(48 2 89 23 7 11 78))
+          (tree-sort  (lambda (< l)
+                        (map car
+                             (bbtree->alist
+                              (alist->bbtree (map (lambda (x) (cons x 'dummy))
+                                                  l)
+                                             <))))))
+      (assert-equal (list-sort < l) (tree-sort < l))))
+
+  (define-test-case bbtrees bbtree-union
+    (let ([empty (make-bbtree char<?)]
+          [bbtree1 (alist->bbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101))
+                                  char<?)]
+          [bbtree2 (alist->bbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12))
+                                  char<?)])
+      (test-case bbtree-union ()
+        (assert-eqv 0 (bbtree-size (bbtree-union empty empty)))
+        (assert-eqv (bbtree-size bbtree1)
+                  (bbtree-size (bbtree-union empty bbtree1)))
+        (assert-eqv (bbtree-size bbtree1)
+                  (bbtree-size (bbtree-union bbtree1 empty)))
+        (assert-eqv (bbtree-size bbtree1)
+                  (bbtree-size (bbtree-union bbtree1 bbtree1)))
+        (assert-equal '(#\e #\g #\i #\l #\p #\s #\u)
+                    (bbtree-keys (bbtree-union bbtree1 bbtree2)))
+        ;; union favours values in first argument when key exists in both
+        (let ((union (bbtree-union bbtree1 bbtree2)))
+          (assert-eqv 105 (bbtree-ref union #\i))
+          (assert-eqv 108 (bbtree-ref union #\l)))
+        ;; 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)])
+          (assert-equal b1
+                      (bbtree->alist (bbtree-union (alist->bbtree b1 char<?)
+                                                   (alist->bbtree b2 char<?))))))))
+
+  (define-test-case bbtrees bbtree-intersection
+    (let ([empty (make-bbtree char<?)]
+          [bbtree1 (alist->bbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101))
+                                  char<?)]
+          [bbtree2 (alist->bbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12))
+                                  char<?)])
+      (test-case bbtree-intersection ()
+        (assert-eqv 0 (bbtree-size (bbtree-intersection empty empty)))
+        (assert-eqv 0 (bbtree-size (bbtree-intersection bbtree1 empty)))
+        (assert-eqv 0 (bbtree-size (bbtree-intersection empty bbtree1)))
+        (assert-eqv (bbtree-size bbtree1)
+                  (bbtree-size (bbtree-intersection bbtree1 bbtree1)))
+        ;; intersection favours values in first set
+        (assert-equal '((#\i . 105) (#\l . 108))
+                    (bbtree->alist (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)])
+          (assert-equal b1
+                      (bbtree->alist (bbtree-intersection (alist->bbtree b1 char<?)
+                                                          (alist->bbtree b2 char<?)))))
+        ;; definition of intersection is equivalent to two differences
+        (assert-equal (bbtree->alist (bbtree-intersection bbtree1 bbtree2))
+                    (bbtree->alist
+                     (bbtree-difference bbtree1
+                                        (bbtree-difference bbtree1 bbtree2)))))))
+
+  (define-test-case bbtrees bbtree-difference
+    (let ([empty (make-bbtree char<?)]
+          [bbtree1 (alist->bbtree '((#\g . 103) (#\u . 117) (#\i . 105) (#\l . 108) (#\e . 101))
+                                  char<?)]
+          [bbtree2 (alist->bbtree '((#\l . 8) (#\i . 5) (#\s . 15) (#\p . 12))
+                                  char<?)])
+      (test-case bbtree-difference ()
+        (assert-eqv 0 (bbtree-size (bbtree-difference empty empty)))
+        (assert-eqv 5 (bbtree-size (bbtree-difference bbtree1 empty)))
+        (assert-eqv 0 (bbtree-size (bbtree-difference empty bbtree1)))
+        (assert-eqv 0 (bbtree-size (bbtree-difference bbtree1 bbtree1)))
+        (assert-equal '((#\e . 101) (#\g . 103) (#\u . 117))
+                    (bbtree->alist (bbtree-difference bbtree1 bbtree2)))
+        (assert-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) char<?)])
+      "tnerfgxukscjmwhaod yz"
+      (test-case bbtree-difference ()
+        (assert-equal '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
+                    (map (lambda (x) (bbtree-index bb x)) l))
+        (assert-raises assertion-violation? (bbtree-index bb #\z))
+        (assert-equal l
+                    (map (lambda (x)
+                           (let-values ([(k v) (bbtree-ref/index bb x)])
+                             k))
+                         '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)))
+        (assert-raises assertion-violation? (bbtree-ref/index bb -1))
+        (assert-raises assertion-violation? (bbtree-ref/index bb 15)))))
+
+)

test/deques.scm

@@ -0,0 +1,120 @@
+(library (test deques)
+  (export deques)
+  (import (rnrs (6))
+          (chez-test suite)
+          (chez-test assertions)
+          (test utils)
+          (pfds deques))
+
+  (define-test-suite deques
+    "Tests for the functional deque implementation")
+
+  (define-test-case deques empty-deque ()
+    (assert-predicate deque? (make-deque))
+    (assert-predicate deque-empty? (make-deque))
+    (assert-eqv 0 (deque-length (make-deque))))
+
+  (define-test-case deques deque-insert ()
+    (let ((deq (enqueue-front (make-deque) 'foo)))
+      (assert-predicate deque? deq)
+      (assert-eqv 1 (deque-length deq)))
+    (let ((deq (enqueue-rear (make-deque) 'foo)))
+      (assert-predicate deque? deq)
+      (assert-eqv 1 (deque-length deq)))
+    (assert-eqv 5 (deque-length
+                 (fold-left (lambda (deque pair)
+                          ((car pair) deque (cdr pair)))
+                        (make-deque)
+                        `((,enqueue-front . 0)
+                          (,enqueue-rear  . 1)
+                          (,enqueue-front . 2)
+                          (,enqueue-rear  . 3)
+                          (,enqueue-front . 4))))))
+
+  (define-test-case deques deque-remove ()
+    (let ((deq (enqueue-front (make-deque) 'foo)))
+      (let-values (((item0 deque0) (dequeue-front deq))
+                   ((item1 deque1) (dequeue-rear deq)))
+        (assert-eqv 'foo item0)
+        (assert-eqv 'foo item1)
+        (assert-predicate deque-empty? deque0)
+        (assert-predicate deque-empty? deque1)))
+    (let ((deq (fold-left (lambda (deque item)
+                        (enqueue-rear deque item))
+                      (make-deque)
+                      '(0 1 2 3 4 5))))
+      (let*-values (((item0 deque0) (dequeue-front deq))
+                    ((item1 deque1) (dequeue-front deque0))
+                    ((item2 deque2) (dequeue-front deque1)))
+        (assert-eqv 0 item0)
+        (assert-eqv 1 item1)
+        (assert-eqv 2 item2)
+        (assert-eqv 3 (deque-length deque2))))
+    (let ((deq (fold-left (lambda (deque item)
+                        (enqueue-rear deque item))
+                      (make-deque)
+                      '(0 1 2 3 4 5))))
+      (let*-values (((item0 deque0) (dequeue-rear deq))
+                    ((item1 deque1) (dequeue-rear deque0))
+                    ((item2 deque2) (dequeue-rear deque1)))
+        (assert-eqv 5 item0)
+        (assert-eqv 4 item1)
+        (assert-eqv 3 item2)
+        (assert-eqv 3 (deque-length deque2))))
+    (let ((empty (make-deque)))
+      (assert-eqv #t
+                (guard (exn ((deque-empty-condition? exn) #t)
+                            (else #f))
+                  (dequeue-front empty)
+                  #f))
+      (assert-eqv #t
+                (guard (exn ((deque-empty-condition? exn) #t)
+                            (else #f))
+                  (dequeue-rear empty)
+                  #f))))
+
+
+  (define-test-case deques mixed-operations ()
+    (let ((deque (fold-left (lambda (deque pair)
+                          ((car pair) deque (cdr pair)))
+                        (make-deque)
+                        `((,enqueue-front . 0)
+                          (,enqueue-rear  . 1)
+                          (,enqueue-front . 2)
+                          (,enqueue-rear  . 3)
+                          (,enqueue-front . 4)))))
+      (let*-values (((item0 deque) (dequeue-front deque))
+                    ((item1 deque) (dequeue-front deque))
+                    ((item2 deque) (dequeue-front deque))
+                    ((item3 deque) (dequeue-front deque))
+                    ((item4 deque) (dequeue-front deque)))
+        (assert-eqv 4 item0)
+        (assert-eqv 2 item1)
+        (assert-eqv 0 item2)
+        (assert-eqv 1 item3)
+        (assert-eqv 3 item4)))
+    (let ((deq (fold-left (lambda (deque item)
+                        (enqueue-rear deque item))
+                      (make-deque)
+                      '(0 1 2))))
+      (let*-values (((item0 deque0) (dequeue-rear deq))
+                    ((item1 deque1) (dequeue-front deque0))
+                    ((item2 deque2) (dequeue-rear deque1)))
+        (assert-eqv 2 item0)
+        (assert-eqv 0 item1)
+        (assert-eqv 1 item2)
+        (assert-predicate deque-empty? deque2))))
+
+  (define-test-case deques list-conversion ()
+    (let ((id-list (lambda (list)
+                     (deque->list (list->deque list))))
+          (l1 '())
+          (l2 '(1 2 3))
+          (l3 '(4 5 6 7 8 9 10))
+          (l4 (string->list "abcdefghijklmnopqrstuvwxyz")))
+      (assert-equal l1 (id-list l1))
+      (assert-equal l2 (id-list l2))
+      (assert-equal l3 (id-list l3))
+      (assert-equal l4 (id-list l4))))
+
+)