1 ;;; -*- mode: scheme; coding: utf-8; -*-
3 ;;; Copyright (C) 2010 Free Software Foundation, Inc.
4 ;;; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
6 ;;; This code is based on the file examples.scm in the reference
7 ;;; implementation of SRFI-67, provided under the following license:
9 ;;; Permission is hereby granted, free of charge, to any person obtaining
10 ;;; a copy of this software and associated documentation files (the
11 ;;; ``Software''), to deal in the Software without restriction, including
12 ;;; without limitation the rights to use, copy, modify, merge, publish,
13 ;;; distribute, sublicense, and/or sell copies of the Software, and to
14 ;;; permit persons to whom the Software is furnished to do so, subject to
15 ;;; the following conditions:
17 ;;; The above copyright notice and this permission notice shall be
18 ;;; included in all copies or substantial portions of the Software.
20 ;;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
21 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
22 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
23 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
24 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
25 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
26 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
29 (define-module (test-srfi-67)
30 #:use-module (test-suite lib)
31 #:use-module (srfi srfi-42)
32 #:use-module (srfi srfi-67))
34 ; =============================================================================
39 ; We use an extended version of the checker of SRFI-42 (with
40 ; Felix' reduction on codesize) for running a batch of tests for
41 ; the various procedures of 'compare.scm'. Moreover, we use the
42 ; comprehensions of SRFI-42 to generate examples systematically.
44 ; (my-check expr => desired-result)
45 ; evaluates expr and compares the value with desired-result.
47 (define-syntax my-check
49 ((my-check expr => desired-result)
50 (my-check-proc 'expr (lambda () expr) desired-result))))
52 (define (my-check-proc expr thunk desired-result)
53 (pass-if expr (equal? (thunk) desired-result)))
55 ; (my-check-ec <qualifier>* <ok?> <expr>)
56 ; runs (every?-ec <qualifier>* <ok?>), counting the times <ok?>
57 ; is evaluated as a correct example, and stopping at the first
58 ; counter example for which <expr> provides the argument.
60 (define-syntax my-check-ec
61 (syntax-rules (nested)
62 ((my-check-ec (nested q1 ...) q etc1 etc2 etc ...)
63 (my-check-ec (nested q1 ... q) etc1 etc2 etc ...))
64 ((my-check-ec q1 q2 etc1 etc2 etc ...)
65 (my-check-ec (nested q1 q2) etc1 etc2 etc ...))
66 ((my-check-ec ok? expr)
67 (my-check-ec (nested) ok? expr))
68 ((my-check-ec (nested q ...) ok? expr)
70 '(every?-ec q ... ok?)
79 ((my-check-ec q ok? expr)
80 (my-check-ec (nested q) ok? expr))))
82 (define (my-check-ec-proc expr thunk arg-counter-example)
83 (pass-if expr (eqv? (thunk) 'ok)))
85 ; =============================================================================
90 (define ci integer-compare) ; very frequently used
92 ; (result-ok? actual desired)
93 ; tests if actual and desired specify the same ordering.
95 (define (result-ok? actual desired)
96 (eqv? actual desired))
98 ; (my-check-compare compare increasing-elements)
99 ; evaluates (compare x y) for x, y in increasing-elements
100 ; and checks the result against -1, 0, or 1 depending on
101 ; the position of x and y in the list increasing-elements.
103 (define-syntax my-check-compare
105 ((my-check-compare compare increasing-elements)
107 (:list x (index ix) increasing-elements)
108 (:list y (index iy) increasing-elements)
109 (result-ok? (compare x y) (ci ix iy))
114 (define my-booleans '(#f #t))
115 (define my-chars '(#\a #\b #\c))
116 (define my-chars-ci '(#\a #\B #\c #\D))
117 (define my-strings '("" "a" "aa" "ab" "b" "ba" "bb"))
118 (define my-strings-ci '("" "a" "aA" "Ab" "B" "bA" "BB"))
119 (define my-symbols '(a aa ab b ba bb))
122 (append-ec (:range xn -6 7)
124 (list x (+ x (exact->inexact (/ 1 100))))))
127 (list-ec (:list x my-reals)
128 (and (exact? x) (rational? x))
132 (list-ec (:list x my-reals)
133 (if (and (exact? x) (integer? x)))
137 (list-ec (:list re-x my-reals)
139 (:list im-x my-reals)
141 (make-rectangular re-x im-x)))
144 '(() (1) (1 1) (1 2) (2) (2 1) (2 2)))
146 (define my-vector-as-lists
147 (map list->vector my-lists))
149 (define my-list-as-vectors
150 '(() (1) (2) (1 1) (1 2) (2 1) (2 2)))
153 (map list->vector my-list-as-vectors))
155 (define my-null-or-pairs
157 (1) (1 1) (1 2) (1 . 1) (1 . 2)
158 (2) (2 1) (2 2) (2 . 1) (2 . 2)))
161 (append my-null-or-pairs
169 ; =============================================================================
176 ; basic functionality
178 (my-check (if3 -1 'n 'z 'p) => 'n)
179 (my-check (if3 0 'n 'z 'p) => 'z)
180 (my-check (if3 1 'n 'z 'p) => 'p)
182 ; check arguments are evaluated only once
186 (if3 (let ((x0 x)) (set! x (+ x 1)) x0) 'n 'z 'p))
191 (if3 (let ((x0 x)) (set! x (+ x 1)) x0)
192 (begin (set! y (+ y 1)) y)
193 (begin (set! y (+ y 10)) y)
194 (begin (set! y (+ y 100)) y)))
199 (if3 (let ((x0 x)) (set! x (+ x 1)) x0)
200 (begin (set! y (+ y 1)) y)
201 (begin (set! y (+ y 10)) y)
202 (begin (set! y (+ y 100)) y)))
207 (if3 (let ((x0 x)) (set! x (+ x 1)) x0)
208 (begin (set! y (+ y 1)) y)
209 (begin (set! y (+ y 10)) y)
210 (begin (set! y (+ y 100)) y)))
215 (define-syntax my-check-if2
217 ((my-check-if2 if-rel? rel)
220 (my-check (if-rel? -1 'yes 'no) => (if (rel -1 0) 'yes 'no))
221 (my-check (if-rel? 0 'yes 'no) => (if (rel 0 0) 'yes 'no))
222 (my-check (if-rel? 1 'yes 'no) => (if (rel 1 0) 'yes 'no))
224 ; check result of 'laterally challenged if'
225 (my-check (let ((x #f)) (if-rel? -1 (set! x #t)) x) => (rel -1 0))
226 (my-check (let ((x #f)) (if-rel? 0 (set! x #t)) x) => (rel 0 0))
227 (my-check (let ((x #f)) (if-rel? 1 (set! x #t)) x) => (rel 1 0))
229 ; check that <c> is evaluated exactly once
230 (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) -1) #t #f) n) => 1)
231 (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 0) #t #f) n) => 1)
232 (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 1) #t #f) n) => 1)
233 (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) -1) #t) n) => 1)
234 (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 0) #t) n) => 1)
235 (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 1) #t) n) => 1)
240 (my-check-if2 if=? =)
241 (my-check-if2 if<? <)
242 (my-check-if2 if>? >)
243 (my-check-if2 if<=? <=)
244 (my-check-if2 if>=? >=)
245 (my-check-if2 if-not=? (lambda (x y) (not (= x y))))
251 (define-syntax my-check-chain2
253 ((my-check-chain2 rel? rel)
255 ; all chains of length 2
256 (my-check (rel? ci 0 0) => (rel 0 0))
257 (my-check (rel? ci 0 1) => (rel 0 1))
258 (my-check (rel? ci 1 0) => (rel 1 0))
260 ; using default-compare
261 (my-check (rel? 0 0) => (rel 0 0))
262 (my-check (rel? 0 1) => (rel 0 1))
263 (my-check (rel? 1 0) => (rel 1 0))
266 (my-check ((rel? ci) 0 0) => (rel 0 0))
267 (my-check ((rel? ci) 0 1) => (rel 0 1))
268 (my-check ((rel? ci) 1 0) => (rel 1 0))
270 ; using default-compare as a combinator
271 (my-check ((rel?) 0 0) => (rel 0 0))
272 (my-check ((rel?) 0 1) => (rel 0 1))
273 (my-check ((rel?) 1 0) => (rel 1 0))
276 (define (list->set xs) ; xs a list of integers
280 (let max-without-apply ((m 1) (xs xs))
283 (max-without-apply (max m (car xs)) (cdr xs))))))
284 (let ((in-xs? (make-vector (+ max-xs 1) #f)))
285 (do-ec (:list x xs) (vector-set! in-xs? x #t))
286 (list-ec (:vector in? (index x) in-xs?)
290 (define-syntax arguments-used ; set of arguments (integer, >=0) used in compare
292 ((arguments-used (rel1/rel2 compare arg ...))
294 (rel1/rel2 (lambda (x y)
295 (set! used (cons x (cons y used)))
300 (define-syntax my-check-chain3
302 ((my-check-chain3 rel1/rel2? rel1 rel2)
304 ; all chains of length 3
305 (my-check (rel1/rel2? ci 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
306 (my-check (rel1/rel2? ci 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
307 (my-check (rel1/rel2? ci 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
308 (my-check (rel1/rel2? ci 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
309 (my-check (rel1/rel2? ci 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
310 (my-check (rel1/rel2? ci 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
311 (my-check (rel1/rel2? ci 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
312 (my-check (rel1/rel2? ci 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
313 (my-check (rel1/rel2? ci 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
314 (my-check (rel1/rel2? ci 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
315 (my-check (rel1/rel2? ci 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
316 (my-check (rel1/rel2? ci 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
317 (my-check (rel1/rel2? ci 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
319 ; using default-compare
320 (my-check (rel1/rel2? 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
321 (my-check (rel1/rel2? 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
322 (my-check (rel1/rel2? 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
323 (my-check (rel1/rel2? 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
324 (my-check (rel1/rel2? 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
325 (my-check (rel1/rel2? 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
326 (my-check (rel1/rel2? 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
327 (my-check (rel1/rel2? 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
328 (my-check (rel1/rel2? 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
329 (my-check (rel1/rel2? 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
330 (my-check (rel1/rel2? 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
331 (my-check (rel1/rel2? 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
332 (my-check (rel1/rel2? 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
335 (my-check ((rel1/rel2? ci) 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
336 (my-check ((rel1/rel2? ci) 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
337 (my-check ((rel1/rel2? ci) 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
338 (my-check ((rel1/rel2? ci) 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
339 (my-check ((rel1/rel2? ci) 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
340 (my-check ((rel1/rel2? ci) 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
341 (my-check ((rel1/rel2? ci) 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
342 (my-check ((rel1/rel2? ci) 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
343 (my-check ((rel1/rel2? ci) 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
344 (my-check ((rel1/rel2? ci) 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
345 (my-check ((rel1/rel2? ci) 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
346 (my-check ((rel1/rel2? ci) 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
347 (my-check ((rel1/rel2? ci) 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
349 ; as a combinator using default-compare
350 (my-check ((rel1/rel2?) 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
351 (my-check ((rel1/rel2?) 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
352 (my-check ((rel1/rel2?) 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
353 (my-check ((rel1/rel2?) 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
354 (my-check ((rel1/rel2?) 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
355 (my-check ((rel1/rel2?) 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
356 (my-check ((rel1/rel2?) 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
357 (my-check ((rel1/rel2?) 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
358 (my-check ((rel1/rel2?) 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
359 (my-check ((rel1/rel2?) 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
360 (my-check ((rel1/rel2?) 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
361 (my-check ((rel1/rel2?) 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
362 (my-check ((rel1/rel2?) 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
364 ; test if all arguments are type checked
365 (my-check (arguments-used (rel1/rel2? ci 0 1 2)) => '(0 1 2))
366 (my-check (arguments-used (rel1/rel2? ci 0 2 1)) => '(0 1 2))
367 (my-check (arguments-used (rel1/rel2? ci 1 2 0)) => '(0 1 2))
368 (my-check (arguments-used (rel1/rel2? ci 1 0 2)) => '(0 1 2))
369 (my-check (arguments-used (rel1/rel2? ci 2 0 1)) => '(0 1 2))
370 (my-check (arguments-used (rel1/rel2? ci 2 1 0)) => '(0 1 2))
373 (define-syntax my-check-chain
375 ((my-check-chain chain-rel? rel)
377 ; the chain of length 0
378 (my-check (chain-rel? ci) => #t)
380 ; a chain of length 1
381 (my-check (chain-rel? ci 0) => #t)
383 ; all chains of length 2
384 (my-check (chain-rel? ci 0 0) => (rel 0 0))
385 (my-check (chain-rel? ci 0 1) => (rel 0 1))
386 (my-check (chain-rel? ci 1 0) => (rel 1 0))
388 ; all chains of length 3
389 (my-check (chain-rel? ci 0 0 0) => (rel 0 0 0))
390 (my-check (chain-rel? ci 0 0 1) => (rel 0 0 1))
391 (my-check (chain-rel? ci 0 1 0) => (rel 0 1 0))
392 (my-check (chain-rel? ci 1 0 0) => (rel 1 0 0))
393 (my-check (chain-rel? ci 1 1 0) => (rel 1 1 0))
394 (my-check (chain-rel? ci 1 0 1) => (rel 1 0 1))
395 (my-check (chain-rel? ci 0 1 1) => (rel 0 1 1))
396 (my-check (chain-rel? ci 0 1 2) => (rel 0 1 2))
397 (my-check (chain-rel? ci 0 2 1) => (rel 0 2 1))
398 (my-check (chain-rel? ci 1 2 0) => (rel 1 2 0))
399 (my-check (chain-rel? ci 1 0 2) => (rel 1 0 2))
400 (my-check (chain-rel? ci 2 0 1) => (rel 2 0 1))
401 (my-check (chain-rel? ci 2 1 0) => (rel 2 1 0))
403 ; check if all arguments are used
404 (my-check (arguments-used (chain-rel? ci 0)) => '(0))
405 (my-check (arguments-used (chain-rel? ci 0 1)) => '(0 1))
406 (my-check (arguments-used (chain-rel? ci 1 0)) => '(0 1))
407 (my-check (arguments-used (chain-rel? ci 0 1 2)) => '(0 1 2))
408 (my-check (arguments-used (chain-rel? ci 0 2 1)) => '(0 1 2))
409 (my-check (arguments-used (chain-rel? ci 1 2 0)) => '(0 1 2))
410 (my-check (arguments-used (chain-rel? ci 1 0 2)) => '(0 1 2))
411 (my-check (arguments-used (chain-rel? ci 2 0 1)) => '(0 1 2))
412 (my-check (arguments-used (chain-rel? ci 2 1 0)) => '(0 1 2))
415 (define (check:predicates-from-compare)
417 (my-check-chain2 =? =)
418 (my-check-chain2 <? <)
419 (my-check-chain2 >? >)
420 (my-check-chain2 <=? <=)
421 (my-check-chain2 >=? >=)
422 (my-check-chain2 not=? (lambda (x y) (not (= x y))))
424 (my-check-chain3 </<? < <)
425 (my-check-chain3 </<=? < <=)
426 (my-check-chain3 <=/<? <= <)
427 (my-check-chain3 <=/<=? <= <=)
429 (my-check-chain3 >/>? > >)
430 (my-check-chain3 >/>=? > >=)
431 (my-check-chain3 >=/>? >= >)
432 (my-check-chain3 >=/>=? >= >=)
434 (my-check-chain chain=? =)
435 (my-check-chain chain<? <)
436 (my-check-chain chain>? >)
437 (my-check-chain chain<=? <=)
438 (my-check-chain chain>=? >=)
440 ) ; check:predicates-from-compare
444 (define pairwise-not=?:long-sequences
447 (define (extremal-pivot-sequence r)
448 ; The extremal pivot sequence of order r is a
449 ; permutation of {0..2^(r+1)-2} such that the
450 ; middle element is minimal, and this property
451 ; holds recursively for each binary subdivision.
452 ; This sequence exposes a naive implementation of
453 ; pairwise-not=? chosing the middle element as pivot.
456 (let* ((s (extremal-pivot-sequence (- r 1)))
458 (append (list-ec (:list x s) (+ x 1))
460 (list-ec (:list x s) (+ x ns 1))))))
462 (list (list-ec (: i 4096) i)
463 (list-ec (: i 4097 0 -1) i)
464 (list-ec (: i 4099) (modulo (* 1003 i) 4099))
465 (extremal-pivot-sequence 11))))
467 (define pairwise-not=?:short-sequences
470 (define (combinations/repeats n l)
471 ; return list of all sublists of l of size n,
472 ; the order of the elements occur in the sublists
473 ; of the output is the same as in the input
474 (let ((len (length l)))
477 ((= n 1) (map list l))
478 ((= len 1) (do ((r '() (cons (car l) r))
481 (else (append (combinations/repeats n (cdr l))
482 (map (lambda (c) (cons (car l) c))
483 (combinations/repeats (- n 1) l)))))))
485 (define (permutations l)
486 ; return a list of all permutations of l
487 (let ((len (length l)))
492 (map (lambda (p) (insert-every-where (car l) p))
493 (permutations (cdr l))))))))
495 (define (insert-every-where x xs)
496 (let loop ((result '()) (before '()) (after xs))
497 (let ((new (append before (cons x after))))
499 ((null? after) (cons new result))
500 (else (loop (cons new result)
501 (append before (list (car after)))
504 (define (sequences n max)
507 (combinations/repeats n (list-ec (: i max) i)))))
509 (append-ec (: n 5) (sequences n 5))))
511 (define (colliding-compare x y)
512 (ci (modulo x 3) (modulo y 3)))
514 (define (naive-pairwise-not=? compare . xs)
515 (let ((xs (list->vector xs)))
516 (every?-ec (:range i (- (vector-length xs) 1))
517 (:let xs-i (vector-ref xs i))
518 (:range j (+ i 1) (vector-length xs))
519 (:let xs-j (vector-ref xs j))
520 (not=? compare xs-i xs-j))))
522 (define (check:pairwise-not=?)
525 (my-check (pairwise-not=? ci) => #t)
526 (my-check (pairwise-not=? ci 0) => #t)
529 (my-check (pairwise-not=? ci 0 0) => #f)
530 (my-check (pairwise-not=? ci 0 1) => #t)
531 (my-check (pairwise-not=? ci 1 0) => #t)
534 (my-check (pairwise-not=? ci 0 0 0) => #f)
535 (my-check (pairwise-not=? ci 0 0 1) => #f)
536 (my-check (pairwise-not=? ci 0 1 0) => #f)
537 (my-check (pairwise-not=? ci 1 0 0) => #f)
538 (my-check (pairwise-not=? ci 1 1 0) => #f)
539 (my-check (pairwise-not=? ci 1 0 1) => #f)
540 (my-check (pairwise-not=? ci 0 1 1) => #f)
541 (my-check (pairwise-not=? ci 0 1 2) => #t)
542 (my-check (pairwise-not=? ci 0 2 1) => #t)
543 (my-check (pairwise-not=? ci 1 2 0) => #t)
544 (my-check (pairwise-not=? ci 1 0 2) => #t)
545 (my-check (pairwise-not=? ci 2 0 1) => #t)
546 (my-check (pairwise-not=? ci 2 1 0) => #t)
548 ; n-ary, n large: [0..n-1], [n,n-1..1], 5^[0..96] mod 97
549 (my-check (apply pairwise-not=? ci (list-ec (: i 10) i)) => #t)
550 (my-check (apply pairwise-not=? ci (list-ec (: i 100) i)) => #t)
551 (my-check (apply pairwise-not=? ci (list-ec (: i 1000) i)) => #t)
553 (my-check (apply pairwise-not=? ci (list-ec (: i 10 0 -1) i)) => #t)
554 (my-check (apply pairwise-not=? ci (list-ec (: i 100 0 -1) i)) => #t)
555 (my-check (apply pairwise-not=? ci (list-ec (: i 1000 0 -1) i)) => #t)
557 (my-check (apply pairwise-not=? ci
558 (list-ec (: i 97) (modulo (* 5 i) 97)))
561 ; bury another copy of 72 = 5^50 mod 97 in 5^[0..96] mod 97
562 (my-check (apply pairwise-not=? ci
563 (append (list-ec (: i 0 23) (modulo (* 5 i) 97))
565 (list-ec (: i 23 97) (modulo (* 5 i) 97))))
567 (my-check (apply pairwise-not=? ci
568 (append (list-ec (: i 0 75) (modulo (* 5 i) 97))
570 (list-ec (: i 75 97) (modulo (* 5 i) 97))))
573 ; check if all arguments are used
574 (my-check (arguments-used (pairwise-not=? ci 0)) => '(0))
575 (my-check (arguments-used (pairwise-not=? ci 0 1)) => '(0 1))
576 (my-check (arguments-used (pairwise-not=? ci 1 0)) => '(0 1))
577 (my-check (arguments-used (pairwise-not=? ci 0 2 1)) => '(0 1 2))
578 (my-check (arguments-used (pairwise-not=? ci 1 2 0)) => '(0 1 2))
579 (my-check (arguments-used (pairwise-not=? ci 1 0 2)) => '(0 1 2))
580 (my-check (arguments-used (pairwise-not=? ci 2 0 1)) => '(0 1 2))
581 (my-check (arguments-used (pairwise-not=? ci 2 1 0)) => '(0 1 2))
582 (my-check (arguments-used (pairwise-not=? ci 0 0 0 1 0 0 0 2 0 0 0 3))
585 ; Guess if the implementation is O(n log n):
586 ; The test is run for 2^e pairwise unequal inputs, e >= 1,
587 ; and the number of calls to the compare procedure is counted.
588 ; all pairs: A = Binomial[2^e, 2] = 2^(2 e - 1) * (1 - 2^-e).
589 ; divide and conquer: D = e 2^e.
590 ; Since an implementation can be randomized, the actual count may
591 ; be a random number. We put a threshold at 100 e 2^e and choose
592 ; e such that A/D >= 150, i.e. e >= 12.
593 ; The test is applied to several inputs that are known to cause
594 ; trouble in simplistic sorting algorithms: (0..2^e-1), (2^e+1,2^e..1),
595 ; a pseudo-random permutation, and a sequence with an extremal pivot
596 ; at the center of each subsequence.
599 (:list input pairwise-not=?:long-sequences)
601 (apply pairwise-not=?
603 (set! compares (+ compares 1))
606 ; (display compares) (newline)
607 (< compares (* 100 12 4096)))
610 ; check many short sequences
613 (:list input pairwise-not=?:short-sequences)
615 (apply pairwise-not=? colliding-compare input)
616 (apply naive-pairwise-not=? colliding-compare input))
619 ; check if the arguments are used for short sequences
622 (:list input pairwise-not=?:short-sequences)
624 (apply pairwise-not=?
626 (set! args (cons x (cons y args)))
627 (colliding-compare x y))
629 (equal? (list->set args) (list->set input)))
632 ) ; check:pairwise-not=?
637 (define min/max:sequences
638 (append pairwise-not=?:short-sequences
639 pairwise-not=?:long-sequences))
641 (define (check:min/max)
643 ; all lists of length 1,2,3
644 (my-check (min-compare ci 0) => 0)
645 (my-check (min-compare ci 0 0) => 0)
646 (my-check (min-compare ci 0 1) => 0)
647 (my-check (min-compare ci 1 0) => 0)
648 (my-check (min-compare ci 0 0 0) => 0)
649 (my-check (min-compare ci 0 0 1) => 0)
650 (my-check (min-compare ci 0 1 0) => 0)
651 (my-check (min-compare ci 1 0 0) => 0)
652 (my-check (min-compare ci 1 1 0) => 0)
653 (my-check (min-compare ci 1 0 1) => 0)
654 (my-check (min-compare ci 0 1 1) => 0)
655 (my-check (min-compare ci 0 1 2) => 0)
656 (my-check (min-compare ci 0 2 1) => 0)
657 (my-check (min-compare ci 1 2 0) => 0)
658 (my-check (min-compare ci 1 0 2) => 0)
659 (my-check (min-compare ci 2 0 1) => 0)
660 (my-check (min-compare ci 2 1 0) => 0)
662 (my-check (max-compare ci 0) => 0)
663 (my-check (max-compare ci 0 0) => 0)
664 (my-check (max-compare ci 0 1) => 1)
665 (my-check (max-compare ci 1 0) => 1)
666 (my-check (max-compare ci 0 0 0) => 0)
667 (my-check (max-compare ci 0 0 1) => 1)
668 (my-check (max-compare ci 0 1 0) => 1)
669 (my-check (max-compare ci 1 0 0) => 1)
670 (my-check (max-compare ci 1 1 0) => 1)
671 (my-check (max-compare ci 1 0 1) => 1)
672 (my-check (max-compare ci 0 1 1) => 1)
673 (my-check (max-compare ci 0 1 2) => 2)
674 (my-check (max-compare ci 0 2 1) => 2)
675 (my-check (max-compare ci 1 2 0) => 2)
676 (my-check (max-compare ci 1 0 2) => 2)
677 (my-check (max-compare ci 2 0 1) => 2)
678 (my-check (max-compare ci 2 1 0) => 2)
680 ; check that the first minimal value is returned
681 (my-check (min-compare (pair-compare-car ci)
682 '(0 1) '(0 2) '(0 3))
684 (my-check (max-compare (pair-compare-car ci)
685 '(0 1) '(0 2) '(0 3))
688 ; check for many inputs
690 (:list input min/max:sequences)
691 (= (apply min-compare ci input)
692 (apply min (apply max input) input))
695 (:list input min/max:sequences)
696 (= (apply max-compare ci input)
697 (apply max (apply min input) input))
699 ; Note the stupid extra argument in the apply for
700 ; the standard min/max makes sure the elements are
701 ; identical when apply truncates the arglist.
708 (define kth-largest:sequences
709 pairwise-not=?:short-sequences)
711 (define (naive-kth-largest compare k . xs)
712 (let ((vec (list->vector xs)))
713 ; bubble sort: simple, stable, O(|xs|^2)
714 (do-ec (:range n (- (vector-length vec) 1))
715 (:range i 0 (- (- (vector-length vec) 1) n))
716 (if>? (compare (vector-ref vec i)
717 (vector-ref vec (+ i 1)))
718 (let ((vec-i (vector-ref vec i)))
719 (vector-set! vec i (vector-ref vec (+ i 1)))
720 (vector-set! vec (+ i 1) vec-i))))
721 (vector-ref vec (modulo k (vector-length vec)))))
723 (define (check:kth-largest)
725 ; check extensively against naive-kth-largest
727 (:list input kth-largest:sequences)
728 (: k (- -2 (length input)) (+ (length input) 2))
729 (= (apply naive-kth-largest colliding-compare k input)
730 (apply kth-largest colliding-compare k input))
735 ; compare-by< etc. procedures
737 (define (check:compare-from-predicates)
763 ; with explicit arguments
766 (lambda (x y) (compare-by< < x y))
770 (lambda (x y) (compare-by> > x y))
774 (lambda (x y) (compare-by<= <= x y))
778 (lambda (x y) (compare-by>= >= x y))
782 (lambda (x y) (compare-by=/< = < x y))
786 (lambda (x y) (compare-by=/> = > x y))
789 ) ; check:compare-from-predicates
792 (define (check:atomic)
794 (my-check-compare boolean-compare my-booleans)
796 (my-check-compare char-compare my-chars)
798 (my-check-compare char-compare-ci my-chars-ci)
800 (my-check-compare string-compare my-strings)
802 (my-check-compare string-compare-ci my-strings-ci)
804 (my-check-compare symbol-compare my-symbols)
806 (my-check-compare integer-compare my-integers)
808 (my-check-compare rational-compare my-rationals)
810 (my-check-compare real-compare my-reals)
812 (my-check-compare complex-compare my-complexes)
814 (my-check-compare number-compare my-complexes)
818 (define (check:refine-select-cond)
823 (lambda (x y) (refine-compare))
827 (lambda (x y) (refine-compare (integer-compare x y)))
832 (refine-compare (integer-compare (car x) (car y))
833 (symbol-compare (cdr x) (cdr y))))
834 '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
838 (refine-compare (integer-compare (car x) (car y))
839 (symbol-compare (cadr x) (cadr y))
840 (string-compare (caddr x) (caddr y))))
841 '((1 a "a") (1 b "a") (1 b "b") (2 b "c") (2 c "a") (3 a "b") (3 c "b")))
846 (lambda (x y) (select-compare x y))
852 (integer? (ci x y))))
858 (pair? (integer-compare (car x) (car y))
859 (symbol-compare (cdr x) (cdr y)))))
860 '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
865 (else (integer-compare x y))))
871 (else (integer-compare (car x) (car y))
872 (symbol-compare (cdr x) (cdr y)))))
873 '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
878 (symbol? (symbol-compare x y))
879 (string? (string-compare x y))))
880 '(a b c "a" "b" "c" 1)) ; implicit (else 0)
885 (symbol? (symbol-compare x y))
886 (else (string-compare x y))))
887 '(a b c "a" "b" "c"))
889 ; test if arguments are only evaluated once
892 (let ((nx 0) (ny 0) (nt 0))
893 (select-compare (begin (set! nx (+ nx 1)) 1)
894 (begin (set! ny (+ ny 1)) 2)
895 ((lambda (z) (set! nt (+ nt 1)) #f) 0)
896 ((lambda (z) (set! nt (+ nt 10)) #f) 0)
897 ((lambda (z) (set! nt (+ nt 100)) #f) 0)
905 (lambda (x y) (cond-compare))
911 (((integer? x) (integer? y)) (integer-compare x y))))
917 (((pair? x) (pair? y)) (integer-compare (car x) (car y))
918 (symbol-compare (cdr x) (cdr y)))))
919 '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
924 (else (integer-compare x y))))
930 (else (integer-compare (car x) (car y))
931 (symbol-compare (cdr x) (cdr y)))))
932 '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
937 (((symbol? x) (symbol? y)) (symbol-compare x y))
938 (((string? x) (string? y)) (string-compare x y))))
939 '(a b c "a" "b" "c" 1)) ; implicit (else 0)
944 (((symbol? x) (symbol? y)) (symbol-compare x y))
945 (else (string-compare x y))))
946 '(a b c "a" "b" "c"))
948 ) ; check:refine-select-cond
951 ; We define our own list/vector data structure
952 ; as '(my-list x[1] .. x[n]), n >= 0, in order
953 ; to make sure the default ops don't work on it.
955 (define (my-list-checked obj)
956 (if (and (list? obj) (eqv? (car obj) 'my-list))
958 (error "expected my-list but received" obj)))
960 (define (list->my-list list) (cons 'my-list list))
961 (define (my-empty? x) (null? (cdr (my-list-checked x))))
962 (define (my-head x) (cadr (my-list-checked x)))
963 (define (my-tail x) (cons 'my-list (cddr (my-list-checked x))))
964 (define (my-size x) (- (length (my-list-checked x)) 1))
965 (define (my-ref x i) (list-ref (my-list-checked x) (+ i 1)))
967 (define (check:data-structures)
970 (pair-compare-car ci)
971 '((1 . b) (2 . a) (3 . c)))
974 (pair-compare-cdr ci)
975 '((b . 1) (a . 2) (c . 3)))
979 (my-check-compare pair-compare my-null-or-pairs)
982 (lambda (x y) (pair-compare ci x y))
986 (lambda (x y) (pair-compare ci symbol-compare x y))
987 '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a)))
991 (my-check-compare list-compare my-lists)
994 (lambda (x y) (list-compare ci x y))
998 (lambda (x y) (list-compare x y my-empty? my-head my-tail))
999 (map list->my-list my-lists))
1002 (lambda (x y) (list-compare ci x y my-empty? my-head my-tail))
1003 (map list->my-list my-lists))
1005 ; list-compare-as-vector
1007 (my-check-compare list-compare-as-vector my-list-as-vectors)
1010 (lambda (x y) (list-compare-as-vector ci x y))
1014 (lambda (x y) (list-compare-as-vector x y my-empty? my-head my-tail))
1015 (map list->my-list my-list-as-vectors))
1018 (lambda (x y) (list-compare-as-vector ci x y my-empty? my-head my-tail))
1019 (map list->my-list my-list-as-vectors))
1023 (my-check-compare vector-compare my-vectors)
1026 (lambda (x y) (vector-compare ci x y))
1030 (lambda (x y) (vector-compare x y my-size my-ref))
1031 (map list->my-list my-list-as-vectors))
1034 (lambda (x y) (vector-compare ci x y my-size my-ref))
1035 (map list->my-list my-list-as-vectors))
1037 ; vector-compare-as-list
1039 (my-check-compare vector-compare-as-list my-vector-as-lists)
1042 (lambda (x y) (vector-compare-as-list ci x y))
1046 (lambda (x y) (vector-compare-as-list x y my-size my-ref))
1047 (map list->my-list my-lists))
1050 (lambda (x y) (vector-compare-as-list ci x y my-size my-ref))
1051 (map list->my-list my-lists))
1053 ) ; check:data-structures
1056 (define (check:default-compare)
1058 (my-check-compare default-compare my-objects)
1060 ; check if default-compare refines pair-compare
1063 (:list x (index ix) my-objects)
1064 (:list y (index iy) my-objects)
1065 (:let c-coarse (pair-compare x y))
1066 (:let c-fine (default-compare x y))
1067 (or (eqv? c-coarse 0) (eqv? c-fine c-coarse))
1070 ; check if default-compare passes on debug-compare
1072 (my-check-compare (debug-compare default-compare) my-objects)
1074 ) ; check:default-compare
1077 (define (sort-by-less xs pred) ; trivial quicksort
1078 (if (or (null? xs) (null? (cdr xs)))
1081 (sort-by-less (list-ec (:list x (cdr xs))
1082 (if (pred x (car xs)))
1086 (sort-by-less (list-ec (:list x (cdr xs))
1087 (if (not (pred x (car xs))))
1091 (define (check:more-examples)
1093 ; define recursive order on tree type (nodes are dotted pairs)
1096 (letrec ((c (lambda (x y)
1097 (cond-compare (((null? x) (null? y)) 0)
1098 (else (pair-compare c c x y))))))
1100 (list '() (list '()) (list '() '()) (list (list '())))
1101 ;'(() (() . ()) (() . (() . ())) ((() . ()) . ())) ; Chicken can't parse this ?
1104 ; redefine default-compare using select-compare
1107 (letrec ((c (lambda (x y)
1110 (pair? (pair-compare c c x y))
1111 (boolean? (boolean-compare x y))
1112 (char? (char-compare x y))
1113 (string? (string-compare x y))
1114 (symbol? (symbol-compare x y))
1115 (number? (number-compare x y))
1116 (vector? (vector-compare c x y))
1117 (else (error "unrecognized type in c" x y))))))
1121 ; redefine default-compare using cond-compare
1124 (letrec ((c (lambda (x y)
1126 (((null? x) (null? y)) 0)
1127 (((pair? x) (pair? y)) (pair-compare c c x y))
1128 (((boolean? x) (boolean? y)) (boolean-compare x y))
1129 (((char? x) (char? y)) (char-compare x y))
1130 (((string? x) (string? y)) (string-compare x y))
1131 (((symbol? x) (symbol? y)) (symbol-compare x y))
1132 (((number? x) (number? y)) (number-compare x y))
1133 (((vector? x) (vector? y)) (vector-compare c x y))
1134 (else (error "unrecognized type in c" x y))))))
1138 ; compare strings with character order reversed
1142 (vector-compare-as-list
1143 (lambda (x y) (char-compare y x))
1144 x y string-length string-ref))
1145 '("" "b" "bb" "ba" "a" "ab" "aa"))
1147 ; examples from SRFI text for <? etc.
1149 (my-check (>? "laugh" "LOUD") => #t)
1150 (my-check (<? string-compare-ci "laugh" "LOUD") => #t)
1151 (my-check (sort-by-less '(1 a "b") (<?)) => '("b" a 1))
1152 (my-check (sort-by-less '(1 a "b") (>?)) => '(1 a "b"))
1154 ) ; check:more-examples
1157 ; Real life examples
1158 ; ==================
1160 ; (update/insert compare x s)
1161 ; inserts x into list s, or updates an equivalent element by x.
1162 ; It is assumed that s is sorted with respect to compare,
1163 ; i.e. (apply chain<=? compare s). The result is a list with x
1164 ; replacing the first element s[i] for which (=? compare s[i] x),
1165 ; or with x inserted in the proper place.
1166 ; The algorithm uses linear insertion from the front.
1168 (define (insert/update compare x s) ; insert x into list s, or update
1171 (if3 (compare x (car s))
1174 (cons (car s) (insert/update compare x (cdr s))))))
1176 ; (index-in-vector compare vec x)
1177 ; an index i such that (=? compare vec[i] x), or #f if there is none.
1178 ; It is assumed that s is sorted with respect to compare,
1179 ; i.e. (apply chain<=? compare (vector->list s)). If there are
1180 ; several elements equivalent to x then it is unspecified which
1182 ; The algorithm uses binary search.
1184 (define (index-in-vector compare vec x)
1185 (let binary-search ((lo -1) (hi (vector-length vec)))
1186 ; invariant: vec[lo] < x < vec[hi]
1187 (if (=? (- hi lo) 1)
1189 (let ((mi (quotient (+ lo hi) 2)))
1190 (if3 (compare x (vector-ref vec mi))
1191 (binary-search lo mi)
1193 (binary-search mi hi))))))
1199 ; comment in/out as needed
1200 (with-test-prefix "atomic" (check:atomic))
1201 (with-test-prefix "if3" (check:if3))
1202 (with-test-prefix "ifs" (check:ifs))
1203 (with-test-prefix "predicates-form-compare"
1204 (check:predicates-from-compare))
1205 (with-test-prefix "pairwise-not=?"
1206 (check:pairwise-not=?))
1207 (with-test-prefix "min/max"
1209 (with-test-prefix "kth-largest"
1210 (check:kth-largest))
1211 (with-test-prefix "compare-from-predicates"
1212 (check:compare-from-predicates))
1213 (with-test-prefix "refine-select-cond"
1214 (check:refine-select-cond))
1215 (with-test-prefix "data-structures"
1216 (check:data-structures))
1217 (with-test-prefix "default-compare"
1218 (check:default-compare))
1219 (with-test-prefix "more-examples"
1220 (check:more-examples))