orginal SRFI 40/43 tests from Schematics

svn: r3335

collects/tests/srfi/40/all-srfi-40-tests.ss

@@ -0,0 +1,88 @@
+(module all-srfi-40-tests mzscheme
+  
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
+           (lib "40.ss" "srfi"))
+  (provide all-srfi-40-tests)
+  
+  (define from0
+    (let loop ((x 0))
+      (stream-delay
+       (stream-cons x (loop (+ x 1))))))
+  (define (take5 s)
+    (stream-unfoldn
+     (lambda (x)
+       (let ((n (car x)) (s (cdr x)))
+         (if (zero? n)
+             (values 'dummy '())
+             (values
+              (cons (- n 1) (stream-cdr s))
+              (list (stream-car s))))))
+     (cons 5 s)
+     1))
+  (define (finite-stream->list s)
+    (if (stream-null? s)
+        null
+        (cons (stream-car s)
+              (finite-stream->list (stream-cdr s)))))
+  
+  (define all-srfi-40-tests
+    (make-test-suite 
+     "All tests for SRFI 40"
+     (make-test-case
+      "stream?"
+      (assert-true
+       (stream? stream-null))
+      (assert-true
+       (stream? (stream-cons 'a stream-null)))
+      (assert-false
+       (stream? 3)))
+     (make-test-case
+      "stream-null?"
+      (assert-true
+       (stream-null? stream-null))
+      (assert-false
+       (stream-null? (stream-cons 'a stream-null)))
+      (assert-false
+       (stream-null? 3)))
+     (make-test-case
+      "stream-pair?"
+      (assert-false
+       (stream-pair? stream-null))
+      (assert-true
+       (stream-pair? (stream-cons 'a stream-null)))
+      (assert-false
+       (stream-pair? 3)))
+     (make-test-case
+      "stream"
+      (assert-true
+       (stream-null? (stream)))
+      (assert-equal? (finite-stream->list (stream 'a (+ 3 4) 'c))
+                     '(a 7 c)))
+     (make-test-case
+      "stream-unfoldn"
+      (assert-equal? (finite-stream->list (take5 from0))
+                     '(0 1 2 3 4)))
+     (make-test-case
+      "stream-for-each"
+      (assert-equal?
+       (let ((l '()))
+         (stream-for-each (lambda (n) (set! l (cons n l)))
+                          (take5 from0))
+         l)
+       '(4 3 2 1 0)))
+     (make-test-case
+      "stream-map"
+      (assert-equal? (finite-stream->list (take5 (stream-map (lambda (x) (+ x x)) from0)))
+                     '(0 2 4 6 8))
+      (assert-equal? (finite-stream->list (stream-map + (stream 1 2 3) (stream 4 5 6)))
+                     '(5 7 9))
+      (assert-equal? (finite-stream->list
+                      (stream-map (lambda (x) (expt x x))
+                                  (stream 1 2 3 4 5)))
+                     '(1 4 27 256 3125)))
+     (make-test-case
+      "stream-filter"
+      (assert-true
+       (stream-null? (stream-filter odd? stream-null)))
+      (assert-equal? (finite-stream->list (take5 (stream-filter odd? from0)))
+                     '(1 3 5 7 9))))))

collects/tests/srfi/40/run-tests.ss

@@ -0,0 +1,5 @@
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1)))
+(require "all-srfi-40-tests.ss")
+
+(test/text-ui all-srfi-40-tests)

collects/tests/srfi/43/all-srfi-43-tests.ss

@@ -0,0 +1,20 @@
+(module all-srfi-43-tests mzscheme
+  
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
+           "constructor-tests.ss"
+           "predicate-tests.ss"
+           "iteration-tests.ss"
+           "searching-tests.ss"
+           "mutator-tests.ss"
+           "conversion-tests.ss")
+  (provide all-srfi-43-tests)
+  
+  (define all-srfi-43-tests
+    (make-test-suite 
+     "all-tests-tests"
+     constructor-tests
+     predicate-tests
+     iteration-tests
+     searching-tests
+     mutator-tests
+     conversion-tests)))

collects/tests/srfi/43/constructor-tests.ss

@@ -0,0 +1,111 @@
+(module constructor-tests mzscheme
+
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+  (require (lib "constructors.ss" "srfi" "43"))
+
+  (provide constructor-tests)
+
+  (define constructor-tests
+    (make-test-suite
+     "All tests for constructor"
+     (make-test-case
+      "vector-unfold"
+      (assert-equal?
+       (vector-unfold values 10)
+       #(0 1 2 3 4 5 6 7 8 9)
+       "No seed")
+      (assert-equal?
+       (vector-unfold (lambda (i x) (values x (- x 1))) 10 0)
+       #(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+       "Single seed")
+      (assert-equal?
+       (vector-unfold (lambda (i a b) (values (/ a b) a b)) 4 5 5)
+       #(1 1 1 1)
+       "Two seeds"))
+
+     (make-test-case
+      "vector-unfold-right"
+      (assert-equal?
+       (vector-unfold-right values 10)
+       #(0 1 2 3 4 5 6 7 8 9)
+       "No seed")
+      (assert-equal?
+       (vector-unfold-right
+        (lambda (i x) (values x (- x 1)))
+        10
+        0)
+       #(-9 -8 -7 -6 -5 -4 -3 -2 -1 0)
+       "Single seed")
+      (assert-equal?
+       (vector-unfold-right
+        (lambda (i a b) (values (/ a b) a b))
+        4
+        5
+        5)
+       #(1 1 1 1)
+       "Two seeds"))
+
+     (make-test-case
+      "vector-copy"
+      (assert-equal?
+       (vector-copy '#(a b c d e f g h i))
+       #(a b c d e f g h i))
+      (assert-equal?
+       (vector-copy '#(a b c d e f g h i) 6)
+       #(g h i))
+      (assert-equal?
+       (vector-copy '#(a b c d e f g h i) 3 6)
+       #(d e f))
+      (assert-equal?
+       (vector-copy '#(a b c d e f g h i) 6 12 'x)
+       #(g h i x x x)))
+
+     (make-test-case
+      "vector-reverse-copy"
+      (assert-equal?
+       (vector-reverse-copy '#(5 4 3 2 1 0) 1 5)
+       #(1 2 3 4))
+      (assert-equal?
+       (vector-reverse-copy '#(5 4 3 2 1 0) 2)
+       #(0 1 2 3))
+      (assert-equal?
+       (vector-reverse-copy '#(5 4 3 2 1 0))
+       #(0 1 2 3 4 5)))
+
+     (make-test-case
+      "vector-append"
+      (assert-equal?
+       (vector-append '#(x) '#(y))
+       #(x y))
+      (assert-equal?
+       (vector-append '#(a) '#(b c d))
+       #(a b c d))
+      (assert-equal?
+       (vector-append '#(a #(b)) '#(#(c)))
+       #(a #(b) #(c)))
+      (assert-equal?
+       (vector-append '#(1 2) '#(3) '#(4 5 6 7))
+       #(1 2 3 4 5 6 7))
+      (assert-equal?
+       (vector-append)
+       #()))
+
+     (make-test-case
+      "vector-concatenate"
+      (assert-equal?
+       (vector-concatenate '(#(x) #(y)))
+       #(x y))
+      (assert-equal?
+       (vector-concatenate '(#(a) #(b c d)))
+       #(a b c d))
+      (assert-equal?
+       (vector-concatenate '(#(a #(b)) #(#(c))))
+       #(a #(b) #(c)))
+      (assert-equal?
+       (vector-concatenate '(#(1 2) #(3) #(4 5 6 7)))
+       #(1 2 3 4 5 6 7))
+      (assert-equal?
+       (vector-concatenate '())
+       #()))
+     ))
+  )

collects/tests/srfi/43/conversion-tests.ss

@@ -0,0 +1,45 @@
+(module conversion-tests mzscheme
+  
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+  (require (all-except (lib "conversion.ss" "srfi" "43") vector->list)
+           (rename (lib "conversion.ss" "srfi" "43") s:vector->list vector->list))
+  
+  (provide conversion-tests)
+  
+  (define conversion-tests
+    (make-test-suite
+     "All tests for conversion"
+     (make-test-case
+      "vector->list"
+      (assert-equal?
+       (s:vector->list '#(1 2 3 4))
+       '(1 2 3 4))
+      (assert-equal?
+       (s:vector->list '#(1 2 3 4) 4)
+       '())
+      (assert-equal?
+       (s:vector->list '#(1 2 3 4) 1 3)
+       '(2 3)))
+     
+     (make-test-case
+      "reverse-vector->list"
+      (assert-equal?
+       (reverse-vector->list '#(1 2 3 4))
+       '(4 3 2 1))
+      (assert-equal?
+       (reverse-vector->list '#(1 2 3 4) 4)
+       '())
+      (assert-equal?
+       (reverse-vector->list '#(1 2 3 4) 1 3)
+       '(3 2)))
+     
+     (make-test-case
+      "reverse-list->vector"
+      (assert-equal?
+       (reverse-list->vector '(1 2 3 4))
+       '#(4 3 2 1))
+      (assert-equal?
+       (reverse-list->vector '())
+       '#()))
+     ))
+  )

collects/tests/srfi/43/iteration-tests.ss

@@ -0,0 +1,119 @@
+(module iteration-tests mzscheme
+  
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+  (require (lib "iteration.ss" "srfi" "43")
+           (lib "constructors.ss" "srfi" "43"))
+  
+  (provide iteration-tests)
+  
+  (define iteration-tests
+    (make-test-suite
+     "All tests for iteration"
+     (make-test-case
+      "vector-fold"
+      (assert =
+              (vector-fold (lambda (index len str) (max (string-length str) len))
+                           0 '#("abcde" "1234" "bar"))
+              5)
+      (assert-equal?
+       (vector-fold (lambda (index tail elt) (cons elt tail))
+                    '() '#(1 2 3 4 5))
+       '(5 4 3 2 1)
+       "reverse-vector->list")
+      (assert =
+              (vector-fold (lambda (index counter n)
+                             (if (even? n) (+ counter 1) counter))
+                           0 '#(1 2 3 4 5))
+              2)
+      (assert-equal?
+       (vector-fold (lambda (index tail elt1 elt2)
+                      (cons (list elt1 elt2) tail))
+                    '()
+                    '#(1 2 3 4 5)
+                    '#(a b c d))
+       '((4 d) (3 c) (2 b) (1 a))
+       "two vectors"))
+     
+     (make-test-case
+      "vector-fold-right"
+      (assert-equal?
+       (vector-fold-right (lambda (index tail elt) (cons elt tail))
+                          '() '#(a b c d))
+       '(a b c d)
+       "vector->list")
+      (assert-equal?
+       (vector-fold-right (lambda (index tail elt1 elt2)
+                            (cons (list elt1 elt2) tail))
+                          '()
+                          '#(1 2 3 4 5)
+                          '#(a b c d))
+       '((1 a) (2 b) (3 c) (4 d))
+       "two vectors"))
+     
+     (make-test-case
+      "vector-map"
+      (assert-equal?
+       (vector-map (lambda (i x) (* x x))
+                   '#(1 2 3 4))
+       '#(1 4 9 16))
+      (assert-equal?
+       (vector-map (lambda (i x y) (* x y))
+                   (vector-unfold (lambda (i x) (values x (+ x 1))) 5 1)
+                   (vector-unfold (lambda (i x) (values x (- x 1))) 5 5))
+       '#(5 8 9 8 5))
+      (assert-equal?
+       (vector-map (lambda (i elt) (+ i elt)) '#(1 2 3 4))
+       '#(1 3 5 7)))
+     
+     (make-test-case
+      "vector-map!"
+      (let ((vec '#(1 2 3 4)))
+        (assert-equal?
+         (begin (vector-map! (lambda (i x) (* x x))
+                             vec)
+                vec)
+         '#(1 4 9 16)))
+      (let ((vec1 (vector-unfold (lambda (i x) (values x (+ x 1))) 5 1))
+            (vec2 (vector-unfold (lambda (i x) (values x (- x 1))) 5 5)))
+        (assert-equal?
+         (begin (vector-map! (lambda (i x y) (* x y))
+                             vec1 vec2)
+                vec1)
+         '#(5 8 9 8 5)))
+      (let ((vec '#(1 2 3 4)))
+        (assert-equal?
+         (begin (vector-map! (lambda (i elt) (+ i elt))
+                             vec)
+                vec)
+         '#(1 3 5 7))))
+     
+     (make-test-case
+      "vector-for-each"
+      (let ((vec1 '#(1 2 3 4))
+            (vec2 (make-vector 4)))
+        (assert-equal?
+         (begin (vector-for-each (lambda (i elt)
+                                   (vector-set! vec2 i (+ i elt)))
+                                 vec1)
+                vec2)
+         '#(1 3 5 7)))
+      (let ((vec1 (vector-unfold (lambda (i x) (values x (+ x 1))) 5 1))
+            (vec2 (vector-unfold (lambda (i x) (values x (- x 1))) 5 5))
+            (vec3 (make-vector 5)))
+        (assert-equal?
+         (begin (vector-for-each (lambda (i x y)
+                                   (vector-set! vec3 i (* x y)))
+                                 vec1 vec2)
+                vec3)
+         '#(5 8 9 8 5))))
+     
+     (make-test-case
+      "vector-count"
+      (assert =
+              (vector-count (lambda (i elt) (even? elt)) '#(3 1 4 1 5 9 2 5 6))
+              3)
+      (assert =
+              (vector-count (lambda (i x y) (< x y)) '#(1 3 6 9) '#(2 4 6 8 10 12))
+              2))
+     ))
+  )

collects/tests/srfi/43/mutator-tests.ss

@@ -0,0 +1,103 @@
+(module mutator-tests mzscheme
+  
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+  (require (all-except (lib "mutators.ss" "srfi" "43") vector-fill!)
+           (rename (lib "mutators.ss" "srfi" "43") s:vector-fill! vector-fill!))
+  
+  (provide mutator-tests)
+  
+  (define mutator-tests
+    (make-test-suite
+     "All tests for mutator"
+     (make-test-case
+      "vector-swap!"
+      (let ((vec '#(a b c d e)))
+        (assert-equal?
+         (begin (vector-swap! vec 1 3)
+                vec)
+         '#(a d c b e)))
+      (let ((vec '#(0 1 2)))
+        (assert-equal?
+         (begin (vector-swap! vec 1 1)
+                vec)
+         '#(0 1 2))))
+     
+     (make-test-case
+      "vector-fill!"
+      (let ((vec '#(1 2 3 4 5)))
+        (assert-equal?
+         (begin (s:vector-fill! vec 0)
+                vec)
+         '#(0 0 0 0 0)))
+      (let ((vec '#(1 2 3 4 5)))
+        (assert-equal?
+         (begin (s:vector-fill! vec 0 1)
+                vec)
+         '#(1 0 0 0 0)))
+      (let ((vec '#(1 2 3 4 5)))
+        (assert-equal?
+         (begin (s:vector-fill! vec 0 1 4)
+                vec)
+         '#(1 0 0 0 5))))
+     
+     (make-test-case
+      "vector-reverse!"
+      (let ((vec '#(1 2 3 4 5)))
+        (assert-equal?
+         (begin (vector-reverse! vec)
+                vec)
+         '#(5 4 3 2 1)))
+      (let ((vec '#(1 2 3 4 5)))
+        (assert-equal?
+         (begin (vector-reverse! vec 1)
+                vec)
+         '#(1 5 4 3 2)))
+      (let ((vec '#(1 2 3 4 5)))
+        (assert-equal?
+         (begin (vector-reverse! vec 1 4)
+                vec)
+         '#(1 4 3 2 5))))
+     
+     (make-test-case
+      "vector-copy!"
+      (let ((source '#(1 2 3 4 5))
+            (target '#(0 0 0 0 0)))
+        (assert-equal?
+         (begin (vector-copy! target 0 source)
+                target)
+         source))
+      (let ((source '#(1 2 3 4 5))
+            (target '#(0 0 0 0 0)))
+        (assert-equal?
+         (begin (vector-copy! target 1 source 1)
+                target)
+         '#(0 2 3 4 5)))
+      (let ((source '#(1 2 3 4 5))
+            (target '#(0 0 0 0 0)))
+        (assert-equal?
+         (begin (vector-copy! target 1 source 1 4)
+                target)
+         '#(0 2 3 4 0))))
+     
+     (make-test-case
+      "vector-reverse-copy!"
+      (let ((source '#(1 2 3 4 5))
+            (target '#(0 0 0 0 0)))
+        (assert-equal?
+         (begin (vector-reverse-copy! target 0 source)
+                target)
+         '#(5 4 3 2 1)))
+      (let ((source '#(1 2 3 4 5))
+            (target '#(0 0 0 0 0)))
+        (assert-equal?
+         (begin (vector-reverse-copy! target 1 source 1)
+                target)
+         '#(0 5 4 3 2)))
+      (let ((source '#(1 2 3 4 5))
+            (target '#(0 0 0 0 0)))
+        (assert-equal?
+         (begin (vector-reverse-copy! target 1 source 1 4)
+                target)
+         '#(0 4 3 2 0))))
+     ))
+  )

collects/tests/srfi/43/predicate-tests.ss

@@ -0,0 +1,42 @@
+(module predicate-tests mzscheme
+
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+  (require (lib "predicates.ss" "srfi" "43"))
+
+  (provide predicate-tests)
+
+  (define predicate-tests
+    (make-test-suite
+     "All tests for predicate"
+     (make-test-case
+      "vector-empty?"
+      (assert-false
+       (vector-empty? '#(a)))
+      (assert-false
+       (vector-empty? '#(())))
+      (assert-false
+       (vector-empty? '#(#())))
+      (assert-true
+       (vector-empty? '#())))
+
+     (make-test-case
+      "vector="
+      (assert-true
+       (vector= eq? '#(a b c d) '#(a b c d)))
+      (assert-false
+       (vector= eq? '#(a b c d) '#(a b d c)))
+      (assert-false
+       (vector= = '#(1 2 3 4 5) '#(1 2 3 4)))
+      (assert-true
+       (vector= = '#(1 2 3 4) '#(1 2 3 4) '#(1 2 3 4)))
+      (assert-true
+       (vector= eq?))
+      (assert-true
+       (vector= eq? '#(a)))
+      (assert-false
+       (vector= eq? '#(a b c d) '#(a b c d) '#(a b d c)))
+      (assert-false
+       (vector= eq? '#(a b c d e) '#(a b c d) '#(a b c d))))
+     ))
+  )
+     

collects/tests/srfi/43/run-tests.ss

@@ -0,0 +1,5 @@
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 1 1)))
+(require "all-srfi-43-tests.ss")
+
+(test/text-ui all-srfi-43-tests)

collects/tests/srfi/43/searching-tests.ss

@@ -0,0 +1,106 @@
+(module searching-tests mzscheme
+  
+  (require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)))
+  (require (lib "searching.ss" "srfi" "43"))
+  
+  (provide searching-tests)
+  
+  (define searching-tests
+    (make-test-suite
+     "All tests for searching"
+     (make-test-case
+      "vector-index"
+      (assert =
+              (vector-index even? '#(3 1 4 1 5 9))
+              2)
+      (assert =
+              (vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+              1)
+      (assert-false
+       (vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))))
+     
+     (make-test-case
+      "vector-index-right"
+      (assert =
+              (vector-index-right even? '#(3 1 4 1 5 9))
+              2)
+      (assert =
+              (vector-index-right < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+              3)
+      (assert-false
+       (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))))
+     
+     (make-test-case
+      "vector-skip"
+      (assert =
+              (vector-skip odd? '#(3 1 4 1 5 9))
+              2)
+      (assert =
+              (vector-skip > '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+              1)
+      (assert-false
+       (vector-skip = '#(2 7 1 8 2 8) '#(2 7 1 8 2))))
+     
+     (make-test-case
+      "vector-skip-right"
+      (assert =
+              (vector-skip-right odd? '#(3 1 4 1 5 9))
+              2)
+      (assert =
+              (vector-skip-right > '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+              3)
+      (assert-false
+       (vector-skip-right = '#(2 7 1 8 2 8) '#(2 7 1 8 2))))
+     
+     (make-test-case
+      "vector-binary-search"
+      (assert =
+              (vector-binary-search '#(0 3 4 6 8 9) 0 -)
+              0)
+      (assert =
+              (vector-binary-search '#(0 3 4 6 8 9) 3 -)
+              1)
+      (assert =
+              (vector-binary-search '#(0 3 4 6 8 9) 4 -)
+              2)
+      (assert =
+              (vector-binary-search '#(0 3 4 6 8 9) 6 -)
+              3)
+      (assert =
+              (vector-binary-search '#(0 3 4 6 8 9) 8 -)
+              4)
+      (assert =
+              (vector-binary-search '#(0 3 4 6 8 9) 9 -)
+              5)
+      (assert-false
+       (vector-binary-search '#(0 3 4 6 8 9) 5 -))
+      (assert-false
+       (vector-binary-search '#(0 3 4 6 8 9) -2 -))
+      (assert-false
+       (vector-binary-search '#(0 3 4 6 8 9) 11 -))
+      (assert-false
+       (vector-binary-search '#(0 3 4 6 8 9) 1 -)))
+     
+     (make-test-case
+      "vector-any"
+      (assert-false
+       (vector-any zero? '#(1 2 3 4)))
+      (assert-true
+       (vector-any zero? '#(2 0 1)))
+      (assert =
+              (vector-any / '#(1 1) '#(1 0))
+              1)
+      (assert-false
+       (vector-any (lambda x #t) '#())))
+     
+     (make-test-case
+      "vector-every"
+      (assert-false
+       (vector-every zero? '#(0 0 7)))
+      (assert-true
+       (vector-every (lambda x #f) '#()))
+      (assert =
+              (vector-every - '#(1 1) '#(1 0))
+              1))
+     ))
+  )

collects/tests/srfi/all-srfi-tests.ss

@@ -6,8 +6,8 @@
            "13/string-test.ss"
            "14/char-set-test.ss"
            "26/cut-test.ss"
-           ;"40/all-srfi-40-tests.ss"
+           "40/all-srfi-40-tests.ss"
-           ;"43/all-srfi-43-tests.ss"
+           "43/all-srfi-43-tests.ss"
            "69/hash-tests.ss")
   (provide all-srfi-tests)
   
@@ -19,8 +19,8 @@
      string-tests
      char-set-tests
      cut-tests
-     ;all-srfi-40-tests
+     all-srfi-40-tests
-     ;all-srfi-43-tests
+     all-srfi-43-tests
      hash-tests
      ))
   )