test-suite/tests/srfi-67.test

   1 ;;; -*- mode: scheme; coding: utf-8; -*-
   2
   3 ;;; Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
   5 ;;;
   6 ;;; This code is based on the file examples.scm in the reference
   7 ;;; implementation of SRFI-67, provided under the following license:
   8 ;;;
   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:
  16 ;;;
  17 ;;; The above copyright notice and this permission notice shall be
  18 ;;; included in all copies or substantial portions of the Software.
  19 ;;;
  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.
  27 ;;;
  28
  29 (define-module (test-srfi-67)
  30   #:use-module (test-suite lib)
  31   #:use-module (srfi srfi-42)
  32   #:use-module (srfi srfi-67))
  33
  34 ; =============================================================================
  35
  36 ; Test engine
  37 ; ===========
  38 ;
  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.
  43
  44 ; (my-check expr => desired-result)
  45 ;   evaluates expr and compares the value with desired-result.
  46
  47 (define-syntax my-check
  48   (syntax-rules (=>)
  49     ((my-check expr => desired-result)
  50      (my-check-proc 'expr (lambda () expr) desired-result))))
  51
  52 (define (my-check-proc expr thunk desired-result)
  53   (pass-if expr (equal? (thunk) desired-result)))
  54
  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.
  59
  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)
  69      (my-check-ec-proc
  70       '(every?-ec q ... ok?)
  71       (lambda ()
  72         (first-ec
  73          'ok
  74          (nested q ...)
  75          (:let ok ok?)
  76          (if (not ok))
  77          (list expr)))
  78       'expr))
  79     ((my-check-ec q ok? expr)
  80      (my-check-ec (nested q) ok? expr))))
  81
  82 (define (my-check-ec-proc expr thunk arg-counter-example)
  83   (pass-if expr (eqv? (thunk) 'ok)))
  84
  85 ; =============================================================================
  86
  87 ; Abstractions etc.
  88 ; =================
  89
  90 (define ci integer-compare) ; very frequently used
  91
  92 ; (result-ok? actual desired)
  93 ;   tests if actual and desired specify the same ordering.
  94
  95 (define (result-ok? actual desired)
  96   (eqv? actual desired))
  97
  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.
 102
 103 (define-syntax my-check-compare
 104   (syntax-rules ()
 105     ((my-check-compare compare increasing-elements)
 106      (my-check-ec
 107       (:list x (index ix) increasing-elements)
 108       (:list y (index iy) increasing-elements)
 109       (result-ok? (compare x y) (ci ix iy))
 110       (list x y)))))
 111
 112 ; sorted lists
 113
 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))
 120
 121 (define my-reals
 122   (append-ec (:range xn -6 7)
 123              (:let x (/ xn 3))
 124              (list x (+ x (exact->inexact (/ 1 100))))))
 125
 126 (define my-rationals
 127   (list-ec (:list x my-reals)
 128            (and (exact? x) (rational? x))
 129            x))
 130
 131 (define my-integers
 132   (list-ec (:list x my-reals)
 133            (if (and (exact? x) (integer? x)))
 134            x))
 135
 136 (define my-complexes
 137   (list-ec (:list re-x my-reals)
 138            (if (inexact? re-x))
 139            (:list im-x my-reals)
 140            (if (inexact? im-x))
 141            (make-rectangular re-x im-x)))
 142
 143 (define my-lists
 144   '(() (1) (1 1) (1 2) (2) (2 1) (2 2)))
 145
 146 (define my-vector-as-lists
 147   (map list->vector my-lists))
 148
 149 (define my-list-as-vectors
 150   '(() (1) (2) (1 1) (1 2) (2 1) (2 2)))
 151
 152 (define my-vectors
 153   (map list->vector my-list-as-vectors))
 154
 155 (define my-null-or-pairs
 156   '(()
 157     (1) (1 1) (1 2) (1 . 1) (1 . 2)
 158     (2) (2 1) (2 2) (2 . 1) (2 . 2)))
 159
 160 (define my-objects
 161   (append my-null-or-pairs
 162           my-booleans
 163           my-chars
 164           my-strings
 165           my-symbols
 166           my-integers
 167           my-vectors))
 168
 169 ; =============================================================================
 170
 171 ; The checks
 172 ; ==========
 173
 174 (define (check:if3)
 175
 176   ; basic functionality
 177
 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)
 181
 182   ; check arguments are evaluated only once
 183
 184   (my-check
 185    (let ((x -1))
 186      (if3 (let ((x0 x)) (set! x (+ x 1)) x0) 'n 'z 'p))
 187    => 'n)
 188
 189   (my-check
 190    (let ((x -1) (y 0))
 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)))
 195    => 1)
 196
 197   (my-check
 198    (let ((x 0) (y 0))
 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)))
 203    => 10)
 204
 205   (my-check
 206    (let ((x 1) (y 0))
 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)))
 211    => 100)
 212
 213   ) ; check:if3
 214
 215 (define-syntax my-check-if2
 216   (syntax-rules ()
 217     ((my-check-if2 if-rel? rel)
 218      (begin
 219        ; check result
 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))
 223
 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))
 228
 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)
 236        ))))
 237
 238 (define (check:ifs)
 239
 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))))
 246
 247   ) ; check:if2
 248
 249 ; <? etc. macros
 250
 251 (define-syntax my-check-chain2
 252   (syntax-rules ()
 253     ((my-check-chain2 rel? rel)
 254      (begin
 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))
 259
 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))
 264
 265        ; as a combinator
 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))
 269
 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))
 274        ))))
 275
 276 (define (list->set xs) ; xs a list of integers
 277   (if (null? xs)
 278       '()
 279       (let ((max-xs
 280              (let max-without-apply ((m 1) (xs xs))
 281                (if (null? xs)
 282                    m
 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?)
 287                    (if in?)
 288                    x)))))
 289
 290 (define-syntax arguments-used ; set of arguments (integer, >=0) used in compare
 291   (syntax-rules ()
 292     ((arguments-used (rel1/rel2 compare arg ...))
 293      (let ((used '()))
 294        (rel1/rel2 (lambda (x y)
 295                     (set! used (cons x (cons y used)))
 296                     (compare x y))
 297                   arg ...)
 298        (list->set used)))))
 299
 300 (define-syntax my-check-chain3
 301   (syntax-rules ()
 302     ((my-check-chain3 rel1/rel2? rel1 rel2)
 303      (begin
 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)))
 318
 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)))
 333
 334        ; as a combinator
 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)))
 348
 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)))
 363
 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))
 371        ))))
 372
 373 (define-syntax my-check-chain
 374   (syntax-rules ()
 375     ((my-check-chain chain-rel? rel)
 376      (begin
 377        ; the chain of length 0
 378        (my-check (chain-rel? ci) => #t)
 379
 380        ; a chain of length 1
 381        (my-check (chain-rel? ci 0) => #t)
 382
 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))
 387
 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))
 402
 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))
 413        ))))
 414
 415 (define (check:predicates-from-compare)
 416
 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))))
 423
 424   (my-check-chain3 </<?   <  <)
 425   (my-check-chain3 </<=?  <  <=)
 426   (my-check-chain3 <=/<?  <= <)
 427   (my-check-chain3 <=/<=? <= <=)
 428
 429   (my-check-chain3 >/>?   >  >)
 430   (my-check-chain3 >/>=?  >  >=)
 431   (my-check-chain3 >=/>?  >= >)
 432   (my-check-chain3 >=/>=? >= >=)
 433
 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>=? >=)
 439
 440   ) ; check:predicates-from-compare
 441
 442 ; pairwise-not=?
 443
 444 (define pairwise-not=?:long-sequences
 445   (let ()
 446
 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.
 454       (if (zero? r)
 455           '(0)
 456           (let* ((s (extremal-pivot-sequence (- r 1)))
 457                  (ns (length s)))
 458             (append (list-ec (:list x s) (+ x 1))
 459                     '(0)
 460                     (list-ec (:list x s) (+ x ns 1))))))
 461
 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))))
 466
 467 (define pairwise-not=?:short-sequences
 468   (let ()
 469
 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)))
 475         (cond
 476           ((= n 0)   '())
 477           ((= n 1)   (map list l))
 478           ((= len 1) (do ((r '() (cons (car l) r))
 479                           (i n (- i 1)))
 480                        ((= i 0) (list r))))
 481           (else      (append (combinations/repeats n (cdr l))
 482                              (map (lambda (c) (cons (car l) c))
 483                                   (combinations/repeats (- n 1) l)))))))
 484
 485     (define (permutations l)
 486       ; return a list of all permutations of l
 487       (let ((len (length l)))
 488         (cond
 489           ((= len 0) '(()))
 490           ((= len 1) (list l))
 491           (else      (apply append
 492                             (map (lambda (p) (insert-every-where (car l) p))
 493                                  (permutations (cdr l))))))))
 494
 495     (define (insert-every-where x xs)
 496       (let loop ((result '()) (before '()) (after  xs))
 497         (let ((new (append before (cons x after))))
 498           (cond
 499             ((null? after) (cons new result))
 500             (else          (loop (cons new result)
 501                                  (append before (list (car after)))
 502                                  (cdr after)))))))
 503
 504     (define (sequences n max)
 505       (apply append
 506              (map permutations
 507                   (combinations/repeats n (list-ec (: i max) i)))))
 508
 509     (append-ec (: n 5) (sequences n 5))))
 510
 511 (define (colliding-compare x y)
 512   (ci (modulo x 3) (modulo y 3)))
 513
 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))))
 521
 522 (define (check:pairwise-not=?)
 523
 524   ; 0-ary, 1-ary
 525   (my-check (pairwise-not=? ci)   => #t)
 526   (my-check (pairwise-not=? ci 0) => #t)
 527
 528   ; 2-ary
 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)
 532
 533   ; 3-ary
 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)
 547
 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)
 552
 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)
 556
 557   (my-check (apply pairwise-not=? ci
 558                    (list-ec (: i 97) (modulo (* 5 i) 97)))
 559             => #t)
 560
 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))
 564                            '(72)
 565                            (list-ec (: i 23 97) (modulo (* 5 i) 97))))
 566             => #f)
 567   (my-check (apply pairwise-not=? ci
 568                    (append (list-ec (: i 0 75) (modulo (* 5 i) 97))
 569                            '(72)
 570                            (list-ec (: i 75 97) (modulo (* 5 i) 97))))
 571             => #f)
 572
 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))
 583             => '(0 1 2 3))
 584
 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.
 597
 598   (my-check-ec
 599    (:list input pairwise-not=?:long-sequences)
 600    (let ((compares 0))
 601      (apply pairwise-not=?
 602             (lambda (x y)
 603               (set! compares (+ compares 1))
 604               (ci x y))
 605             input)
 606      ;     (display compares) (newline)
 607      (< compares (* 100 12 4096)))
 608    (length input))
 609
 610   ; check many short sequences
 611
 612   (my-check-ec
 613    (:list input pairwise-not=?:short-sequences)
 614    (eq?
 615     (apply pairwise-not=? colliding-compare input)
 616     (apply naive-pairwise-not=? colliding-compare input))
 617    input)
 618
 619   ; check if the arguments are used for short sequences
 620
 621   (my-check-ec
 622    (:list input pairwise-not=?:short-sequences)
 623    (let ((args '()))
 624      (apply pairwise-not=?
 625             (lambda (x y)
 626               (set! args (cons x (cons y args)))
 627               (colliding-compare x y))
 628             input)
 629      (equal? (list->set args) (list->set input)))
 630    input)
 631
 632   ) ; check:pairwise-not=?
 633
 634
 635 ; min/max
 636
 637 (define min/max:sequences
 638   (append pairwise-not=?:short-sequences
 639           pairwise-not=?:long-sequences))
 640
 641 (define (check:min/max)
 642
 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)
 661
 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)
 679
 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))
 683             => '(0 1))
 684   (my-check (max-compare (pair-compare-car ci)
 685                          '(0 1) '(0 2) '(0 3))
 686             => '(0 1))
 687
 688   ; check for many inputs
 689   (my-check-ec
 690    (:list input min/max:sequences)
 691    (= (apply min-compare ci input)
 692       (apply min (apply max input) input))
 693    input)
 694   (my-check-ec
 695    (:list input min/max:sequences)
 696    (= (apply max-compare ci input)
 697       (apply max (apply min input) input))
 698    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.
 702
 703   ) ; check:min/max
 704
 705
 706 ; kth-largest
 707
 708 (define kth-largest:sequences
 709   pairwise-not=?:short-sequences)
 710
 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)))))
 722
 723 (define (check:kth-largest)
 724
 725   ; check extensively against naive-kth-largest
 726   (my-check-ec
 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))
 731    (list input k))
 732
 733   ) ;check:kth-largest
 734
 735 ; compare-by< etc. procedures
 736
 737 (define (check:compare-from-predicates)
 738
 739   (my-check-compare
 740    (compare-by< <)
 741    my-integers)
 742
 743   (my-check-compare
 744    (compare-by> >)
 745    my-integers)
 746
 747   (my-check-compare
 748    (compare-by<= <=)
 749    my-integers)
 750
 751   (my-check-compare
 752    (compare-by>= >=)
 753    my-integers)
 754
 755   (my-check-compare
 756    (compare-by=/< = <)
 757    my-integers)
 758
 759   (my-check-compare
 760    (compare-by=/> = >)
 761    my-integers)
 762
 763   ; with explicit arguments
 764
 765   (my-check-compare
 766    (lambda (x y) (compare-by< < x y))
 767    my-integers)
 768
 769   (my-check-compare
 770    (lambda (x y) (compare-by> > x y))
 771    my-integers)
 772
 773   (my-check-compare
 774    (lambda (x y) (compare-by<= <= x y))
 775    my-integers)
 776
 777   (my-check-compare
 778    (lambda (x y) (compare-by>= >= x y))
 779    my-integers)
 780
 781   (my-check-compare
 782    (lambda (x y) (compare-by=/< = < x y))
 783    my-integers)
 784
 785   (my-check-compare
 786    (lambda (x y) (compare-by=/> = > x y))
 787    my-integers)
 788
 789   ) ; check:compare-from-predicates
 790
 791
 792 (define (check:atomic)
 793
 794   (my-check-compare boolean-compare   my-booleans)
 795
 796   (my-check-compare char-compare      my-chars)
 797
 798   (my-check-compare char-compare-ci   my-chars-ci)
 799
 800   (my-check-compare string-compare    my-strings)
 801
 802   (my-check-compare string-compare-ci my-strings-ci)
 803
 804   (my-check-compare symbol-compare    my-symbols)
 805
 806   (my-check-compare integer-compare   my-integers)
 807
 808   (my-check-compare rational-compare  my-rationals)
 809
 810   (my-check-compare real-compare      my-reals)
 811
 812   (my-check-compare complex-compare   my-complexes)
 813
 814   (my-check-compare number-compare    my-complexes)
 815
 816   ) ; check:atomic
 817
 818 (define (check:refine-select-cond)
 819
 820   ; refine-compare
 821
 822   (my-check-compare
 823    (lambda (x y) (refine-compare))
 824    '(#f))
 825
 826   (my-check-compare
 827    (lambda (x y) (refine-compare (integer-compare x y)))
 828    my-integers)
 829
 830   (my-check-compare
 831    (lambda (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)))
 835
 836   (my-check-compare
 837    (lambda (x y)
 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")))
 842
 843   ; select-compare
 844
 845   (my-check-compare
 846    (lambda (x y) (select-compare x y))
 847    '(#f))
 848
 849   (my-check-compare
 850    (lambda (x y)
 851      (select-compare x y
 852                      (integer? (ci x y))))
 853    my-integers)
 854
 855   (my-check-compare
 856    (lambda (x y)
 857      (select-compare 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)))
 861
 862   (my-check-compare
 863    (lambda (x y)
 864      (select-compare x y
 865                      (else (integer-compare x y))))
 866    my-integers)
 867
 868   (my-check-compare
 869    (lambda (x y)
 870      (select-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)))
 874
 875   (my-check-compare
 876    (lambda (x y)
 877      (select-compare x y
 878                      (symbol? (symbol-compare x y))
 879                      (string? (string-compare x y))))
 880    '(a b c "a" "b" "c" 1)) ; implicit (else 0)
 881
 882   (my-check-compare
 883    (lambda (x y)
 884      (select-compare x y
 885                      (symbol? (symbol-compare x y))
 886                      (else    (string-compare x y))))
 887    '(a b c "a" "b" "c"))
 888
 889   ; test if arguments are only evaluated once
 890
 891   (my-check
 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)
 898                      (else 0))
 899      (list nx ny nt))
 900    => '(1 1 222))
 901
 902   ; cond-compare
 903
 904   (my-check-compare
 905    (lambda (x y) (cond-compare))
 906    '(#f))
 907
 908   (my-check-compare
 909    (lambda (x y)
 910      (cond-compare
 911       (((integer? x) (integer? y)) (integer-compare x y))))
 912    my-integers)
 913
 914   (my-check-compare
 915    (lambda (x y)
 916      (cond-compare
 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)))
 920
 921   (my-check-compare
 922    (lambda (x y)
 923      (cond-compare
 924       (else (integer-compare x y))))
 925    my-integers)
 926
 927   (my-check-compare
 928    (lambda (x y)
 929      (cond-compare
 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)))
 933
 934   (my-check-compare
 935    (lambda (x y)
 936      (cond-compare
 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)
 940
 941   (my-check-compare
 942    (lambda (x y)
 943      (cond-compare
 944       (((symbol? x) (symbol? y)) (symbol-compare x y))
 945       (else                      (string-compare x y))))
 946    '(a b c "a" "b" "c"))
 947
 948   ) ; check:refine-select-cond
 949
 950
 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.
 954
 955 (define (my-list-checked obj)
 956   (if (and (list? obj) (eqv? (car obj) 'my-list))
 957       obj
 958       (error "expected my-list but received" obj)))
 959
 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)))
 966
 967 (define (check:data-structures)
 968
 969   (my-check-compare
 970    (pair-compare-car ci)
 971    '((1 . b) (2 . a) (3 . c)))
 972
 973   (my-check-compare
 974    (pair-compare-cdr ci)
 975    '((b . 1) (a . 2) (c . 3)))
 976
 977   ; pair-compare
 978
 979   (my-check-compare pair-compare my-null-or-pairs)
 980
 981   (my-check-compare
 982    (lambda (x y) (pair-compare ci x y))
 983    my-null-or-pairs)
 984
 985   (my-check-compare
 986    (lambda (x y) (pair-compare ci symbol-compare x y))
 987    '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a)))
 988
 989   ; list-compare
 990
 991   (my-check-compare list-compare my-lists)
 992
 993   (my-check-compare
 994    (lambda (x y) (list-compare ci x y))
 995    my-lists)
 996
 997   (my-check-compare
 998    (lambda (x y) (list-compare x y my-empty? my-head my-tail))
 999    (map list->my-list my-lists))
1000
1001   (my-check-compare
1002    (lambda (x y) (list-compare ci x y my-empty? my-head my-tail))
1003    (map list->my-list my-lists))
1004
1005   ; list-compare-as-vector
1006
1007   (my-check-compare list-compare-as-vector my-list-as-vectors)
1008
1009   (my-check-compare
1010    (lambda (x y) (list-compare-as-vector ci x y))
1011    my-list-as-vectors)
1012
1013   (my-check-compare
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))
1016
1017   (my-check-compare
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))
1020
1021   ; vector-compare
1022
1023   (my-check-compare vector-compare my-vectors)
1024
1025   (my-check-compare
1026    (lambda (x y) (vector-compare ci x y))
1027    my-vectors)
1028
1029   (my-check-compare
1030    (lambda (x y) (vector-compare x y my-size my-ref))
1031    (map list->my-list my-list-as-vectors))
1032
1033   (my-check-compare
1034    (lambda (x y) (vector-compare ci x y my-size my-ref))
1035    (map list->my-list my-list-as-vectors))
1036
1037   ; vector-compare-as-list
1038
1039   (my-check-compare vector-compare-as-list my-vector-as-lists)
1040
1041   (my-check-compare
1042    (lambda (x y) (vector-compare-as-list ci x y))
1043    my-vector-as-lists)
1044
1045   (my-check-compare
1046    (lambda (x y) (vector-compare-as-list x y my-size my-ref))
1047    (map list->my-list my-lists))
1048
1049   (my-check-compare
1050    (lambda (x y) (vector-compare-as-list ci x y my-size my-ref))
1051    (map list->my-list my-lists))
1052
1053   ) ; check:data-structures
1054
1055
1056 (define (check:default-compare)
1057
1058   (my-check-compare default-compare my-objects)
1059
1060   ; check if default-compare refines pair-compare
1061
1062   (my-check-ec
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))
1068    (list x y))
1069
1070   ; check if default-compare passes on debug-compare
1071
1072   (my-check-compare (debug-compare default-compare) my-objects)
1073
1074   ) ; check:default-compare
1075
1076
1077 (define (sort-by-less xs pred) ; trivial quicksort
1078   (if (or (null? xs) (null? (cdr xs)))
1079       xs
1080       (append
1081        (sort-by-less (list-ec (:list x (cdr xs))
1082                               (if (pred x (car xs)))
1083                               x)
1084                      pred)
1085        (list (car xs))
1086        (sort-by-less (list-ec (:list x (cdr xs))
1087                               (if (not (pred x (car xs))))
1088                               x)
1089                      pred))))
1090
1091 (define (check:more-examples)
1092
1093   ; define recursive order on tree type (nodes are dotted pairs)
1094
1095   (my-check-compare
1096    (letrec ((c (lambda (x y)
1097                  (cond-compare (((null? x) (null? y)) 0)
1098                                (else (pair-compare c c x y))))))
1099      c)
1100    (list '() (list '()) (list '() '()) (list (list '())))
1101    ;'(() (() . ()) (() . (() . ())) ((() . ()) . ()))   ; Chicken can't parse this ?
1102    )
1103
1104   ; redefine default-compare using select-compare
1105
1106   (my-check-compare
1107    (letrec ((c (lambda (x y)
1108                  (select-compare x y
1109                                  (null? 0)
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))))))
1118      c)
1119    my-objects)
1120
1121   ; redefine default-compare using cond-compare
1122
1123   (my-check-compare
1124    (letrec ((c (lambda (x y)
1125                  (cond-compare
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))))))
1135      c)
1136    my-objects)
1137
1138   ; compare strings with character order reversed
1139
1140   (my-check-compare
1141    (lambda (x y)
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"))
1146
1147   ; examples from SRFI text for <? etc.
1148
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"))
1153
1154   ) ; check:more-examples
1155
1156
1157 ; Real life examples
1158 ; ==================
1159
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.
1167
1168 (define (insert/update compare x s) ; insert x into list s, or update
1169   (if (null? s)
1170       (list x)
1171       (if3 (compare x (car s))
1172            (cons x s)
1173            (cons x (cdr s))
1174            (cons (car s) (insert/update compare x (cdr s))))))
1175
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
1181 ;    these is chosen.
1182 ;      The algorithm uses binary search.
1183
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)
1188         #f
1189         (let ((mi (quotient (+ lo hi) 2)))
1190           (if3 (compare x (vector-ref vec mi))
1191                (binary-search lo mi)
1192                mi
1193                (binary-search mi hi))))))
1194
1195
1196 ; Run the checks
1197 ; ==============
1198
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"
1208   (check: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))
1221