~ chicken-core (chicken-5) /tests/loopy-test.scm

  1(import (only chicken.format printf)
  2        (only chicken.time current-process-milliseconds)
  3	chicken.load)
  4
  5(load-relative "loopy-loop.scm")
  6(load-relative "matchable.scm")
  7
  8
  9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 10;; SRFI-64 subset + test-approx=
 11
 12(define *pass* 0)
 13(define *fail* 0)
 14(define *start* 0)
 15
 16(define (run-test name thunk expect eq pass-msg fail-msg)
 17  (let ((result (thunk)))
 18    (cond
 19      ((eq expect result)
 20       (set! *pass* (+ *pass* 1))
 21       (format-result pass-msg name expect result))
 22      (else
 23       (set! *fail* (+ *fail* 1))
 24       (format-result fail-msg name expect result)))))
 25
 26(define (format-result ls name expect result)
 27  (let lp ((ls ls))
 28    (cond
 29      ((null? ls) (newline))
 30      ((eq? (car ls) 'expect) (display expect) (lp (cdr ls)))
 31      ((eq? (car ls) 'result) (display result) (lp (cdr ls)))
 32      ((eq? (car ls) 'name) (if name (begin (display #\space) (display name))) (lp (cdr ls)))
 33      (else (display (car ls)) (lp (cdr ls))))))
 34
 35(define (test-begin . o)
 36  (set! *pass* 0)
 37  (set! *fail* 0)
 38  (set! *start* (current-process-milliseconds)))
 39
 40(define (format-float n prec)
 41  (let* ((str (number->string n))
 42         (len (string-length str)))
 43    (let lp ((i (- len 1)))
 44      (cond
 45        ((negative? i)
 46         (string-append str "." (make-string prec #\0)))
 47        ((eqv? #\. (string-ref str i))
 48         (let ((diff (+ 1 (- prec (- len i)))))
 49           (cond
 50             ((positive? diff)
 51              (string-append str (make-string diff #\0)))
 52             ((negative? diff)
 53              (substring str 0 (+ i prec 1)))
 54             (else
 55              str))))
 56        (else
 57         (lp (- i 1)))))))
 58
 59(define (format-percent num denom)
 60  (let ((x (if (zero? denom) num (exact->inexact (/ num denom)))))
 61    (format-float (* 100 x) 2)))
 62
 63(define (test-end . o)
 64  (let ((end (current-process-milliseconds))
 65        (total (+ *pass* *fail*)))
 66    (printf "  ~A tests completed in ~A seconds\n"
 67            total (format-float (exact->inexact (/ (- end *start*) 1000)) 3))
 68    (printf "  ~A (~A%) tests passed\n"
 69            *pass* (format-percent *pass* total))
 70    (printf "  ~A (~A%) tests failed\n"
 71            *fail* (format-percent *fail* total))))
 72
 73(define-syntax test-assert
 74  (syntax-rules ()
 75    ((_ x opt)
 76     (run-assert x (lambda () opt)))
 77    ((_ x ) (run-assert 'x (lambda () x)))))
 78
 79(define (run-equal name thunk expect eq)
 80  (run-test name thunk expect eq
 81            '("(PASS)" name)
 82            '("(FAIL)" name ": expected " expect " but got " result)))
 83
 84(define-syntax test-equal
 85  (syntax-rules ()
 86    ((_ x y opt)
 87     (run-equal x (lambda () y) opt equal?))
 88    ((_ x y) (run-equal 'x (lambda () x) y equal?))))
 89
 90;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 91;; run tests
 92
 93(test-begin "loop")
 94
 95(test-equal
 96 "stepping"
 97 (loop lp ((i 0 (+ i 1)) (res '() (cons i res)))
 98   (if (= i 3)
 99     (reverse res)
100     (lp)))
101 '(0 1 2))
102
103(test-equal
104 "basic in-list"
105 (let ((res '()))
106   (loop ((x <- in-list '(a b c)))
107     (set! res (cons x res)))
108   res)
109 '(c b a))
110
111(test-equal
112 "in-list with result"
113 (loop ((x <- in-list '(a b c))
114        (res '() (cons x res)))
115   => res)
116 '(c b a))
117
118(test-equal
119 "in-list with collecting"
120 (loop ((x <- in-list '(a b c)) (res <- collecting x)) => res)
121 '(a b c))
122
123(test-equal
124 "uneven length in-list's"
125 (loop ((x <- in-list '(a b c))
126        (y <- in-list '(1 2 3 4))
127        (res <- collecting (cons x y)))
128    => res)
129 '((a . 1) (b . 2) (c . 3)))
130
131(test-equal
132 "in-lists"
133 (loop ((ls <- in-lists '((a b c) (1 2 3)))
134        (res <- collecting ls))
135   => res)
136 '((a 1) (b 2) (c 3)))
137
138(define (flatten ls)
139  (reverse
140   (loop lp ((x ls <- in-list ls) (res '()))
141       => res
142     (if (pair? x)
143       (lp res <- (lp ls <- x))
144       (lp res <- (cons x res))))))
145
146(test-equal
147 "flatten (recursion test)"
148 (flatten '(1 (2) (3 (4 (5)) 6) 7))
149 '(1 2 3 4 5 6 7))
150
151(test-equal
152 "in-string"
153 (loop ((c <- in-string "hello") (res <- collecting c)) => res)
154 '(#\h #\e #\l #\l #\o))
155
156(test-equal
157 "in-string with start"
158 (loop ((c <- in-string "hello" 3) (res <- collecting c)) => res)
159 '(#\l #\o))
160
161(test-equal
162 "in-string with start and end"
163 (loop ((c <- in-string "hello" 0 4) (res <- collecting c)) => res)
164 '(#\h #\e #\l #\l))
165
166(test-equal
167 "in-string with start, end and step"
168 (loop ((c <- in-string "hello" 1 4 2) (res <- collecting c)) => res)
169 '(#\e #\l))
170
171(test-equal
172 "in-string-reverse"
173 (loop ((c <- in-string-reverse "hello") (res <- collecting c)) => res)
174 '(#\o #\l #\l #\e #\h))
175
176(test-equal
177 "in-vector"
178 (loop ((x <- in-vector '#(1 2 3)) (res <- collecting x)) => res)
179 '(1 2 3))
180
181(test-equal
182 "in-permutations"
183 (loop ((p <- in-permutations '(a b c)) (res <- collecting p)) => res)
184 '((a b c) (a c b) (b a c) (b c a) (c a b) (c b a)))
185
186(test-equal
187 "in-permutations with length"
188 (loop ((p <- in-permutations '(a b c) 2) (res <- collecting p)) => res)
189 '((a b) (a c) (b a) (b c) (c a) (c b)))
190
191(test-equal
192 "in-combinations"
193 (loop ((p <- in-combinations '(a b c) 2) (res <- collecting p)) => res)
194 '((a b) (a c) (b c)))
195
196(test-end "loop")
197