;;; -*- Mode: Scheme -*- ;;;; Extensible Looping Macros ;;;; Test Suite ;;; This code is written by Taylor R. Campbell and placed in the Public ;;; Domain. All warranties are disclaimed. (define-test-suite loop-tests "Taylor R. Campbell's and Alex Shinn's loop macros") (define-test-suite (loop-tests.null-loop loop-tests) "Loops that do nothing") (define-test-case loop-tests.null-loop no-recursive-call () (test-eqv 0 (loop continue () 0))) (define-test-case loop-tests.null-loop loop-until-true () (test-eqv 0 (loop ((until #t)) => 0))) (define-test-suite (loop-tests.trivial-do loop-tests) "Loops trivially translated from DO") (define-test-case loop-tests.trivial-do iota () (test-equal '(0 1 2) (loop continue ((integer 0 (+ integer 1)) (list '() (cons integer list))) (if (= integer 3) (reverse list) (continue))))) (define-test-case loop-tests.trivial-do list-sum () (test-eqv 25 ;; R5RS, 4.2.4, p12, translated from DO. (let ((x '(1 3 5 7 9))) (loop ((x x (cdr x)) (sum 0 (+ sum (car x))) (until (null? x))) => sum)))) (define-test-suite (loop-tests.trivial-named-let loop-tests) "Loops trivially translated from named LET") (define-test-case loop-tests.trivial-named-let successive-sum () (test-eqv 45 (loop continue ((i 0) (sum 0)) (if (= i 10) sum (continue (+ i 1) (+ sum i)))))) (define-test-case loop-tests.trivial-named-let partition-list-by-sign () (test-equal '((6 1 3) (-5 -2)) ;; R5RS, 4.2.4, p12, translated from named LET. (loop continue ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) (cond ((null? numbers) (list nonneg neg)) ((>= (car numbers) 0) (continue (cdr numbers) (cons (car numbers) nonneg) neg)) ((< (car numbers) 0) (continue (cdr numbers) nonneg (cons (car numbers) neg))))))) (define-test-suite (loop-tests.in-list loop-tests) "IN-LIST iterator") (define-test-case loop-tests.in-list sum () (test-eqv 6 (loop ((for element (in-list '(1 2 3))) (with sum 0 (+ sum element))) => sum))) (define-test-case loop-tests.in-list reverse () (test-equal '(2 1 0) (loop ((for element (in-list '(0 1 2))) (with reversed '() (cons element reversed))) => reversed))) (define-test-case loop-tests.in-list find-matching-items () (test-equal '(-4 #F FOO) (let ((items '(3 -1.2 -4 1 FOO 9 2 6 FROTZ))) (define (find-matching-item list predicate) (loop continue ((for item (in-list list))) => #f (if (predicate item) item (continue)))) (list (find-matching-item items (lambda (item) (and (integer? item) (negative? item)))) (find-matching-item items pair?) (find-matching-item items symbol?))))) (define-test-case loop-tests.in-list pairwise-sum () (test-equal '(5 7 9) (loop ((for a (in-list '(1 2 3))) (for b (in-list '(4 5 6))) (with pairwise-sum '() (cons (+ a b) pairwise-sum))) => (reverse pairwise-sum)))) (define-test-case loop-tests.in-list plist->alist () (test-equal '((:X FOO) (:Y BAR) (:Z BAZ)) (loop ((for key tail (in-list '(:X FOO :Y BAR :Z BAZ) cddr)) (with alist '() (cons (list key (cadr tail)) alist))) => (reverse alist)))) (define-test-case loop-tests.in-list partition () (test-equal '((4 2 6) (3 1 1 5 9 5)) (loop continue ((for element (in-list '(3 1 4 1 5 9 2 6 5))) (with even '()) (with odd '())) => (list (reverse even) (reverse odd)) (if (even? element) (continue (=> even (cons element even))) (continue (=> odd (cons element odd))))))) (define-test-case loop-tests.in-list inner-product () (test-equal 32 (loop ((for components (in-lists '((1 2 3) (4 5 6)))) (with inner-product 0 (+ inner-product (loop ((for component (in-list components)) (with product 1 (* product component))) => product)))) => inner-product))) (define-test-case loop-tests.in-list matrix-transposition () (test-equal '((C F) (B E) (A D)) (loop ((for columns (in-lists '((A B C) (D E F)))) (with rows '() (cons columns rows))) => rows))) (define-test-suite (loop-tests.in-vector loop-tests) "IN-VECTOR and IN-VECTOR-REVERSE iterator") (define-test-case loop-tests.in-vector sum () (test-eqv 20 (loop ((for element (in-vector '#(2 4 6 8))) (with sum 0 (+ sum element))) => sum))) (define-test-case loop-tests.in-vector vector-suffix->list () (test-equal '(4 1 5 9) (loop ((for element (in-vector '#(3 1 4 1 5 9) 2)) (with list '() (cons element list))) => (reverse list)))) (define-test-case loop-tests.in-vector subvector->list () (test-equal '(1 4 1 5) (loop ((for element (in-vector-reverse '#(3 1 4 1 5 9) 5 1)) (with list '() (cons element list))) => list))) (define-test-case loop-tests.in-vector reverse-subvector->list () (test-equal '(5 1 4 1) (loop ((for element (in-vector '#(3 1 4 1 5 9) 1 5)) (with list '() (cons element list))) => list))) (define-test-case loop-tests.in-vector linear-search () (test-equal 2 (loop continue ((for element index (in-vector '#(FOO BAR BAZ QUUX)))) (if (eq? element 'BAZ) index (continue))))) (define-test-case loop-tests.in-vector vector-reverse () (test-equal '#(E D C) (let () (define (vector-reverse-copy vector start end) (let* ((length (- end start)) (vector* (make-vector length))) (loop ((for element index (in-vector vector start end))) (vector-set! vector* (- (- end 1) index) element)) vector*)) (vector-reverse-copy '#(A B C D E F G H I) 2 5)))) (define-test-case loop-tests.in-vector accelerated-alphabetic-traversal () (test-equal '((A 0) (B 1) (D 3) (H 7) (P 15)) ((lambda (body) (body '#(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z))) (lambda (alphabet-vector) (loop continue ((for element index (in-vector alphabet-vector)) (with result '() (cons (list element index) result))) => (reverse result) (continue (=> index (+ 1 (* 2 index))))))))) (define-test-suite (loop-tests.in-string loop-tests) "IN-STRING and IN-STRING-REVERSE iterators") (define-test-case loop-tests.in-string linear-search () (test-eqv 4 (loop continue ((for char index (in-string "foobarbaz"))) (if (char=? char #\a) index (continue))))) (define-test-case loop-tests.in-string linear-search-reverse () (test-eqv 7 (loop continue ((for char index (in-string-reverse "foobarbaz"))) => #f (if (char=? char #\a) index (continue))))) (define-test-case loop-tests.in-string string->list () (test-equal '(#\o #\o #\b #\a) (loop ((for char (in-string "foobar" 1 5)) (with chars '() (cons char chars))) => (reverse chars)))) (define-test-suite (loop-tests.io-loops loop-tests) "IN-PORT and IN-FILE iterators") (define-test-case loop-tests.io-loops read-chars () (test-equal '(#\x #\y #\z) (loop ((for char (in-port (open-input-string "xyz"))) (with chars '() (cons char chars))) => (reverse chars)))) (define-test-case loop-tests.io-loops read-expressions () (test-equal '(FOO BAR (BAZ QUUX) #(ZOT)) (loop ((for expression (in-port (open-input-string "foo bar (baz quux) #(zot)") read)) (with expressions '() (cons expression expressions))) => (reverse expressions)))) (define-test-case loop-tests.io-loops read-with-custom-eof () (test-equal '(FOO BAR BAZ) (loop ((for term (in-port (open-input-string "foo bar baz eof quux") read (lambda (term) (if (eof-object? term) (test-failure "Premature real EOF.") (eq? term 'EOF))))) (with terms '() (cons term terms))) => (reverse terms)))) ;++ This should test IN-FILE, but we need some sort of temporary file ;++ generation utility, and to implement setup & teardown actions. (define-test-suite (loop-tests.integer-intervals loop-tests) "UP-FROM and DOWN-FROM iterators") (define-test-case loop-tests.integer-intervals successive-sum () (test-equal 45 (loop ((for i (up-from 0 (to 10))) (with sum 0 (+ sum i))) => sum))) (define-test-case loop-tests.integer-intervals reverse-iota-evens () (test-equal '(8 6 4 2 0) (loop ((for i (up-from 0 (to 10) (by 2))) (with list '() (cons i list))) => list))) (define-test-case loop-tests.integer-intervals iota-odds () (test-equal '(1 3 5 7 9) (loop ((for i (down-from 11 (to 1) (by 2))) (with list '() (cons i list))) => list))) (define-test-case loop-tests.integer-intervals list-of-squares () (test-equal '(0 1 4 9 16) (loop ((for i (down-from 5 (to 0))) (with squares '() (cons (* i i) squares))) => squares))) (define-test-case loop-tests.integer-intervals sieve-of-eratosthenes () (test-equal '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59) (let () (define (make-bit-string size set?) (make-string size (if set? #\1 #\0))) (define (bit-string-set! bit-string index) (string-set! bit-string index #\1)) (define (bit-string-clear! bit-string index) (string-set! bit-string index #\0)) (define (bit-string-set? bit-string index) (char=? #\1 (string-ref bit-string index))) (define (sieve n) (let ((prime-table (make-bit-string (- n 2) #t))) (define (prime? k) (bit-string-set? prime-table (- k 2))) (define (not-prime! k) (bit-string-clear! prime-table (- k 2))) (define (prime! k) (loop ((for i (up-from (* k k) (to n) (by k)))) (not-prime! i))) (loop ((for k (up-from 2 (to n))) (with prime-list '() (if (prime? k) (begin (prime! k) (cons k prime-list)) prime-list))) => (reverse prime-list)))) (sieve 60)))) (define-test-suite (loop-tests.accumulation loop-tests) "Accumulation iterators") (define-test-case loop-tests.accumulation iota () (test-equal '(0 1 2 3 4 5 6 7 8 9) (loop ((for i (up-from 0 (to 10))) (for list (listing i))) => list))) (define-test-case loop-tests.accumulation append () (test-equal '(a b c d e f) (let () (define (append list tail) (loop ((for element (in-list list)) (for tail (listing (initial tail) element))) => tail)) (append '(a b c) '(d e f))))) (define-test-case loop-tests.accumulation append-reverse () (test-equal '(f e d c b a) (let () (define (append-reverse list tail) (loop ((for element (in-list list)) (for tail (listing-reverse (initial tail) element))) => tail)) (append-reverse '(d e f) '(c b a))))) (define-test-case loop-tests.accumulation iota-reverse () (test-equal '(9 8 7 6 5 4 3 2 1 0) (loop ((for i (up-from 0 (to 10))) (for list (listing-reverse i))) => list))) (define-test-case loop-tests.accumulation non-reentrant-map () (test-equal '(1 4 9 16 25) (loop ((for i (in-list '(1 2 3 4 5))) (for squares (listing! (* i i)))) => squares))) (define-test-case loop-tests.accumulation even-product-iota! () (test-equal '(INITIAL 0 4 16 36 64) (let ((x (cons 'INITIAL '()))) (loop ((for i (up-from 0 (to 10))) (for result (listing-into! x (* i i) (if (even? i)))))) x))) (define-test-case loop-tests.accumulation concatenate () (test-equal '(A B C P Q R 0 1 2) (loop ((for list (in-list '((A B C) (P Q R) (0 1 2)))) (for result (appending list))) => result))) (define-test-case loop-tests.accumulation reverse-concatenate () (test-equal '(2 1 0 R Q P C B A) (loop ((for list (in-list '((A B C) (P Q R) (0 1 2)))) (for result (appending-reverse list))) => result))) (define-test-case loop-tests.accumulation maximize-if-even () (test-equal 6 (loop ((for i (in-list '(3 1 4 1 5 9 2 6 5 3 5))) (for j (maximizing i (if (even? i))))) => j))) (define-test-case loop-tests.accumulation minimize-if-odd () (test-equal 1 (loop ((for i (in-list '(3 1 4 1 5 9 2 6 5 3 5))) (for j (minimizing i (if (odd? i))))) => j))) (define-test-case loop-tests.accumulation sum-of-squares-of-valid-numbers () (test-equal 1300 (loop ((for string (in-list '("a" "12" "x" "34"))) (for sum (summing (string->number string) => (lambda (number) (* number number))))) => sum))) (define-test-case loop-tests.accumulation sum-of-valid-even-numbers () (test-equal 24 (loop ((for string (in-list '("a" "2" "3" "6" "b" "16" "17" "x" "19"))) (for sum (summing (values (string->number string)) (lambda (x) (and x (even? x))) => (lambda (number) number)))) => sum))) (define-test-case loop-tests.accumulation factorial () (test-equal 720 (loop ((for i (up-from 1 (to (+ 6 1)))) (for factorial (multiplying i))) => factorial))) (define-test-suite (loop-tests.misc loop-tests) "Miscellaneous loops") (define-test-case loop-tests.misc obfuscated-loop-invocation () (test-equal '((0 () i (i j k p q r)) (1 (0) k (k p q r)) (2 (1 0) q (q r))) (loop continue ((with a 0) (with b '() (cons a b)) (for c d (in-list '(i j k p q r))) (for result (listing (list a b c d)))) => result (continue (+ a 1) (=> d (cddr d)))))) (define-test-case loop-tests.misc vector-quick-sort () (let () (define (vector-copy vector) (let* ((length (vector-length vector)) (vector* (make-vector length))) (loop ((for element index (in-vector vector))) (vector-set! vector* index element)) vector*)) (loop ((for vector (in-list '(#(A B C 8 6 5 3 1 4 0 7 2 9 D E F) #(A B C 2 7 4 9 3 6 8 5 0 1 D E F) #(A B C 0 8 9 3 5 4 6 1 7 2 D E F) #(A B C 7 8 3 0 2 1 4 6 9 5 D E F) #(A B C 9 7 4 8 3 0 1 2 5 6 D E F) #(A B C 1 9 2 6 4 7 3 8 0 5 D E F))))) (let ((vector (vector-copy vector))) (vector-quick-sort! vector 3 (- (vector-length vector) 3) identity-procedure <) (if (not (equal? vector '#(A B C 0 1 2 3 4 5 6 7 8 9 D E F))) (test-failure "Vector quick-sort yielded an unsorted vector:" vector)))))) (define (vector-quick-sort! vector start end key-selector key<) (define (select-pivot vector start end) (vector-ref vector (quotient (+ start end) 2))) (loop sort ((start start) (end end)) (if (< 1 (- end start)) (let ((pivot (key-selector (select-pivot vector start end)))) (loop continue ((i start) (j end)) (let ((i (loop scan ((for i (up-from i))) (if (key< (key-selector (vector-ref vector i)) pivot) (scan) i))) (j (loop scan ((for j (down-from j))) (if (key< pivot (key-selector (vector-ref vector j))) (scan) j)))) (if (< i j) (begin (vector-exchange! vector i j) (continue (+ i 1) j)) (begin (sort (=> end i)) (sort (=> start (+ j 1))))))))))) (define (vector-exchange! vector i j) (let ((vi (vector-ref vector i)) (vj (vector-ref vector j))) (vector-set! vector j vi) (vector-set! vector i vj)))