unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [PATCH] Add implementation of SRFI-67
@ 2010-10-01 22:06 Andreas Rottmann
  2010-10-03 10:18 ` Andy Wingo
  0 siblings, 1 reply; 2+ messages in thread
From: Andreas Rottmann @ 2010-10-01 22:06 UTC (permalink / raw)
  To: Guile Development

[-- Attachment #1: srfi-67.patch --]
[-- Type: attachment, Size: 72789 bytes --]

From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Add implementation of SRFI-67

* module/srfi/srfi-67/compare.scm: New file; reference implementation of
  SRFI 67.
* module/srfi/srfi-67.scm: New module; includes the refernce
  implementation.
* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-67.scm.
  (NOCOMP_SOURCES): Add srfi/srfi-67/compare.scm.

* test-suite/tests/srfi-67.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-67.test.

---
 doc/ref/srfi-modules.texi       |    7 +
 module/Makefile.am              |    2 +
 module/srfi/srfi-67.scm         |   87 +++
 module/srfi/srfi-67/compare.scm |  707 ++++++++++++++++++++++
 test-suite/Makefile.am          |    1 +
 test-suite/tests/srfi-67.test   | 1221 +++++++++++++++++++++++++++++++++++++++
 6 files changed, 2025 insertions(+), 0 deletions(-)

diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 109756a..5efce9d 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -47,6 +47,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-55::                     Requiring Features.
 * SRFI-60::                     Integers as bits.
 * SRFI-61::                     A more general `cond' clause
+* SRFI-67::                     Compare procedures
 * SRFI-69::                     Basic hash tables.
 * SRFI-88::                     Keyword objects.
 * SRFI-98::                     Accessing environment variables.
@@ -4053,6 +4054,12 @@ success.  SRFI 61 is implemented in the Guile core; there's no module
 needed to get SRFI-61 itself.  Extended @code{cond} is documented in
 @ref{if cond case,, Simple Conditional Evaluation}.
 
+@node SRFI-67
+@subsection SRFI-67 - Compare procedures
+@cindex SRFI-67
+
+See @uref{http://srfi.schemers.org/srfi-67/srfi-67.html, the
+specification of SRFI-67}.
 
 @node SRFI-69
 @subsection SRFI-69 - Basic hash tables
diff --git a/module/Makefile.am b/module/Makefile.am
index 6197a43..8062d5a 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -256,6 +256,7 @@ SRFI_SOURCES = \
   srfi/srfi-42.scm \
   srfi/srfi-39.scm \
   srfi/srfi-60.scm \
+  srfi/srfi-67.scm \
   srfi/srfi-69.scm \
   srfi/srfi-88.scm \
   srfi/srfi-98.scm
@@ -351,6 +352,7 @@ NOCOMP_SOURCES =				\
   ice-9/r6rs-libraries.scm			\
   ice-9/quasisyntax.scm				\
   srfi/srfi-42/ec.scm				\
+  srfi/srfi-67/compare.scm			\
   system/base/lalr.upstream.scm			\
   system/repl/describe.scm			\
   sxml/sxml-match.ss				\
diff --git a/module/srfi/srfi-67.scm b/module/srfi/srfi-67.scm
new file mode 100644
index 0000000..8ce8de0
--- /dev/null
+++ b/module/srfi/srfi-67.scm
@@ -0,0 +1,87 @@
+;;; srfi-67.scm --- Compare Procedures
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library. If not, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is not yet documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-67)
+  #:export (</<=?
+            </<?
+            <=/<=?
+            <=/<?
+            <=?
+            <?
+            =?
+            >/>=?
+            >/>?
+            >=/>=?
+            >=/>?
+            >=?
+            >?
+            boolean-compare
+            chain<=?
+            chain<?
+            chain=?
+            chain>=?
+            chain>?
+            char-compare
+            char-compare-ci
+            compare-by<
+            compare-by<=
+            compare-by=/<
+            compare-by=/>
+            compare-by>
+            compare-by>=
+            complex-compare
+            cond-compare
+            debug-compare
+            default-compare
+            if-not=?
+            if3
+            if<=?
+            if<?
+            if=?
+            if>=?
+            if>?
+            integer-compare
+            kth-largest
+            list-compare
+            list-compare-as-vector
+            max-compare
+            min-compare
+            not=?
+            number-compare
+            pair-compare
+            pair-compare-car
+            pair-compare-cdr
+            pairwise-not=?
+            rational-compare
+            real-compare
+            refine-compare
+            select-compare
+            string-compare
+            string-compare-ci
+            symbol-compare
+            vector-compare
+            vector-compare-as-list)
+  #:use-module (srfi srfi-27))
+
+(include-from-path "srfi/srfi-67/compare.scm")
diff --git a/module/srfi/srfi-67/compare.scm b/module/srfi/srfi-67/compare.scm
new file mode 100644
index 0000000..21b0e94
--- /dev/null
+++ b/module/srfi/srfi-67/compare.scm
@@ -0,0 +1,707 @@
+; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
+; 
+; Permission is hereby granted, free of charge, to any person obtaining
+; a copy of this software and associated documentation files (the
+; ``Software''), to deal in the Software without restriction, including
+; without limitation the rights to use, copy, modify, merge, publish,
+; distribute, sublicense, and/or sell copies of the Software, and to
+; permit persons to whom the Software is furnished to do so, subject to
+; the following conditions:
+; 
+; The above copyright notice and this permission notice shall be
+; included in all copies or substantial portions of the Software.
+; 
+; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+; 
+; -----------------------------------------------------------------------
+; 
+; Compare procedures SRFI (reference implementation)
+; Sebastian.Egner@philips.com, Jensaxel@soegaard.net
+; history of this file:
+;   SE, 14-Oct-2004: first version
+;   SE, 18-Oct-2004: 1st redesign: axioms for 'compare function'
+;   SE, 29-Oct-2004: 2nd redesign: higher order reverse/map/refine/unite
+;   SE,  2-Nov-2004: 3rd redesign: macros cond/refine-compare replace h.o.f's
+;   SE, 10-Nov-2004: (im,re) replaced by (re,im) in complex-compare
+;   SE, 11-Nov-2004: case-compare by case (not by cond); select-compare added
+;   SE, 12-Jan-2005: pair-compare-cdr
+;   SE, 15-Feb-2005: stricter typing for compare-<type>; pairwise-not=?
+;   SE, 16-Feb-2005: case-compare -> if-compare -> if3; <? </<? chain<? etc.
+;   JS, 24-Feb-2005: selection-compare added
+;   SE, 25-Feb-2005: selection-compare -> kth-largest modified; if<? etc.
+;   JS, 28-Feb-2005: kth-largest modified - is "stable" now
+;   SE, 28-Feb-2005: simplified pairwise-not=?/kth-largest; min/max debugged
+;   SE, 07-Apr-2005: compare-based type checks made explicit
+;   SE, 18-Apr-2005: added (rel? compare) and eq?-test
+;   SE, 16-May-2005: naming convention changed; compare-by< etc. optional x y
+
+; =============================================================================
+
+; Reference Implementation
+; ========================
+;
+; in R5RS (including hygienic macros)
+;  + SRFI-16 (case-lambda) 
+;  + SRFI-23 (error) 
+;  + SRFI-27 (random-integer)
+
+; Implementation remarks:
+;   * In general, the emphasis of this implementation is on correctness
+;     and portability, not on efficiency.
+;   * Variable arity procedures are expressed in terms of case-lambda
+;     in the hope that this will produce efficient code for the case
+;     where the arity is statically known at the call site.
+;   * In procedures that are required to type-check their arguments,
+;     we use (compare x x) for executing extra checks. This relies on
+;     the assumption that eq? is used to catch this case quickly.
+;   * Care has been taken to reference comparison procedures of R5RS
+;     only at the time the operations here are being defined. This
+;     makes it possible to redefine these operations, if need be.
+;   * For the sake of efficiency, some inlining has been done by hand.
+;     This is mainly expressed by macros producing defines.
+;   * Identifiers of the form compare:<something> are private.
+;
+; Hints for low-level implementation:
+;   * The basis of this SRFI are the atomic compare procedures, 
+;     i.e. boolean-compare, char-compare, etc. and the conditionals
+;     if3, if=?, if<? etc., and default-compare. These should make
+;     optimal use of the available type information.
+;   * For the sake of speed, the reference implementation does not
+;     use a LET to save the comparison value c for the ERROR call.
+;     This can be fixed in a low-level implementation at no cost.
+;   * Type-checks based on (compare x x) are made explicit by the
+;     expression (compare:check result compare x ...).
+;   * Eq? should  can used to speed up built-in compare procedures,
+;     but it can only be used after type-checking at least one of
+;     the arguments.
+
+(define (compare:checked result compare . args)
+  (for-each (lambda (x) (compare x x)) args)
+  result)
+
+
+; 3-sided conditional
+
+(define-syntax if3
+  (syntax-rules ()
+    ((if3 c less equal greater)
+     (case c
+       ((-1) less)
+       (( 0) equal)
+       (( 1) greater)
+       (else (error "comparison value not in {-1,0,1}"))))))
+
+
+; 2-sided conditionals for comparisons
+
+(define-syntax compare:if-rel?
+  (syntax-rules ()
+    ((compare:if-rel? c-cases a-cases c consequence)
+     (compare:if-rel? c-cases a-cases c consequence (if #f #f)))
+    ((compare:if-rel? c-cases a-cases c consequence alternate)
+     (case c
+       (c-cases consequence)
+       (a-cases alternate)
+       (else    (error "comparison value not in {-1,0,1}"))))))
+
+(define-syntax if=?
+  (syntax-rules ()
+    ((if=? arg ...)
+     (compare:if-rel? (0) (-1 1) arg ...))))
+
+(define-syntax if<?
+  (syntax-rules ()
+    ((if<? arg ...)
+     (compare:if-rel? (-1) (0 1) arg ...))))
+
+(define-syntax if>?
+  (syntax-rules ()
+    ((if>? arg ...)
+     (compare:if-rel? (1) (-1 0) arg ...))))
+
+(define-syntax if<=?
+  (syntax-rules ()
+    ((if<=? arg ...)
+     (compare:if-rel? (-1 0) (1) arg ...))))
+
+(define-syntax if>=?
+  (syntax-rules ()
+    ((if>=? arg ...)
+     (compare:if-rel? (0 1) (-1) arg ...))))
+
+(define-syntax if-not=?
+  (syntax-rules ()
+    ((if-not=? arg ...)
+     (compare:if-rel? (-1 1) (0) arg ...))))
+
+
+; predicates from compare procedures
+
+(define-syntax compare:define-rel?
+  (syntax-rules ()
+    ((compare:define-rel? rel? if-rel?)
+     (define rel?
+       (case-lambda
+	(()        (lambda (x y) (if-rel? (default-compare x y) #t #f)))
+	((compare) (lambda (x y) (if-rel? (compare         x y) #t #f)))
+	((x y)                   (if-rel? (default-compare x y) #t #f))
+	((compare x y)
+	 (if (procedure? compare)
+	     (if-rel? (compare x y) #t #f)
+	     (error "not a procedure (Did you mean rel/rel??): " compare))))))))
+
+(compare:define-rel? =?    if=?)
+(compare:define-rel? <?    if<?)
+(compare:define-rel? >?    if>?)
+(compare:define-rel? <=?   if<=?)
+(compare:define-rel? >=?   if>=?)
+(compare:define-rel? not=? if-not=?)
+
+
+; chains of length 3
+
+(define-syntax compare:define-rel1/rel2?
+  (syntax-rules ()
+    ((compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
+     (define rel1/rel2?
+       (case-lambda
+	(()
+	 (lambda (x y z)
+	   (if-rel1? (default-compare x y)
+		     (if-rel2? (default-compare y z) #t #f)
+		     (compare:checked #f default-compare z))))
+	((compare)
+	 (lambda (x y z)
+	   (if-rel1? (compare x y)
+		(if-rel2? (compare y z) #t #f)
+		(compare:checked #f compare z))))
+	((x y z)
+	 (if-rel1? (default-compare x y)
+	       (if-rel2? (default-compare y z) #t #f)
+	       (compare:checked #f default-compare z)))
+	((compare x y z)
+	 (if-rel1? (compare x y)
+	       (if-rel2? (compare y z) #t #f)
+	       (compare:checked #f compare z))))))))
+
+(compare:define-rel1/rel2? </<?   if<?  if<?)
+(compare:define-rel1/rel2? </<=?  if<?  if<=?)
+(compare:define-rel1/rel2? <=/<?  if<=? if<?)
+(compare:define-rel1/rel2? <=/<=? if<=? if<=?)
+(compare:define-rel1/rel2? >/>?   if>?  if>?)
+(compare:define-rel1/rel2? >/>=?  if>?  if>=?)
+(compare:define-rel1/rel2? >=/>?  if>=? if>?)
+(compare:define-rel1/rel2? >=/>=? if>=? if>=?)
+
+
+; chains of arbitrary length
+
+(define-syntax compare:define-chain-rel?
+  (syntax-rules ()
+    ((compare:define-chain-rel? chain-rel? if-rel?)
+     (define chain-rel?
+       (case-lambda
+	((compare)
+	 #t)
+	((compare x1)
+	 (compare:checked #t compare x1))
+	((compare x1 x2)
+	 (if-rel? (compare x1 x2) #t #f))
+	((compare x1 x2 x3)
+	 (if-rel? (compare x1 x2)
+		  (if-rel? (compare x2 x3) #t #f)
+		  (compare:checked #f compare x3)))
+	((compare x1 x2 . x3+)
+	 (if-rel? (compare x1 x2)
+		  (let chain? ((head x2) (tail x3+))
+		    (if (null? tail)
+			#t
+			(if-rel? (compare head (car tail))
+				 (chain? (car tail) (cdr tail))
+				 (apply compare:checked #f 
+					compare (cdr tail)))))
+		  (apply compare:checked #f compare x3+))))))))
+
+(compare:define-chain-rel? chain=?  if=?)
+(compare:define-chain-rel? chain<?  if<?)
+(compare:define-chain-rel? chain>?  if>?)
+(compare:define-chain-rel? chain<=? if<=?)
+(compare:define-chain-rel? chain>=? if>=?)
+
+
+; pairwise inequality
+
+(define pairwise-not=?
+  (let ((= =) (<= <=))
+    (case-lambda
+      ((compare)
+       #t)
+      ((compare x1)
+       (compare:checked #t compare x1))
+      ((compare x1 x2)
+       (if-not=? (compare x1 x2) #t #f))
+      ((compare x1 x2 x3)
+       (if-not=? (compare x1 x2)
+                 (if-not=? (compare x2 x3)
+                           (if-not=? (compare x1 x3) #t #f)
+                           #f)
+		 (compare:checked #f compare x3)))
+      ((compare . x1+)
+       (let unequal? ((x x1+) (n (length x1+)) (unchecked? #t))
+         (if (< n 2)
+	     (if (and unchecked? (= n 1))
+		 (compare:checked #t compare (car x))
+		 #t)
+             (let* ((i-pivot (random-integer n))
+                    (x-pivot (list-ref x i-pivot)))
+               (let split ((i 0) (x x) (x< '()) (x> '()))
+                 (if (null? x)
+                     (and (unequal? x< (length x<) #f)
+                          (unequal? x> (length x>) #f))
+                     (if (= i i-pivot)
+                         (split (+ i 1) (cdr x) x< x>)
+                         (if3 (compare (car x) x-pivot)
+                              (split (+ i 1) (cdr x) (cons (car x) x<) x>)
+			      (if unchecked?
+				  (apply compare:checked #f compare (cdr x))
+				  #f)
+                              (split (+ i 1) (cdr x) x< (cons (car x) x>)))))))))))))
+
+
+; min/max
+
+(define min-compare
+  (case-lambda
+    ((compare x1)
+     (compare:checked x1 compare x1))
+    ((compare x1 x2)
+     (if<=? (compare x1 x2) x1 x2))
+    ((compare x1 x2 x3)
+     (if<=? (compare x1 x2)
+            (if<=? (compare x1 x3) x1 x3)
+            (if<=? (compare x2 x3) x2 x3)))
+    ((compare x1 x2 x3 x4)
+     (if<=? (compare x1 x2)
+            (if<=? (compare x1 x3)
+                   (if<=? (compare x1 x4) x1 x4)
+                   (if<=? (compare x3 x4) x3 x4))
+            (if<=? (compare x2 x3)
+                   (if<=? (compare x2 x4) x2 x4)
+                   (if<=? (compare x3 x4) x3 x4))))
+    ((compare x1 x2 . x3+)
+     (let min ((xmin (if<=? (compare x1 x2) x1 x2)) (xs x3+))
+       (if (null? xs)
+           xmin
+           (min (if<=? (compare xmin (car xs)) xmin (car xs))
+                (cdr xs)))))))
+
+(define max-compare
+  (case-lambda
+    ((compare x1)
+     (compare:checked x1 compare x1))
+    ((compare x1 x2)
+     (if>=? (compare x1 x2) x1 x2))
+    ((compare x1 x2 x3)
+     (if>=? (compare x1 x2)
+            (if>=? (compare x1 x3) x1 x3)
+            (if>=? (compare x2 x3) x2 x3)))
+    ((compare x1 x2 x3 x4)
+     (if>=? (compare x1 x2)
+            (if>=? (compare x1 x3)
+                   (if>=? (compare x1 x4) x1 x4)
+                   (if>=? (compare x3 x4) x3 x4))
+            (if>=? (compare x2 x3)
+                   (if>=? (compare x2 x4) x2 x4)
+                   (if>=? (compare x3 x4) x3 x4))))
+    ((compare x1 x2 . x3+)
+     (let max ((xmax (if>=? (compare x1 x2) x1 x2)) (xs x3+))
+       (if (null? xs)
+           xmax
+           (max (if>=? (compare xmax (car xs)) xmax (car xs))
+                (cdr xs)))))))
+
+
+; kth-largest
+
+(define kth-largest
+  (let ((= =) (< <))
+    (case-lambda
+      ((compare k x0)
+       (case (modulo k 1)
+         ((0)  (compare:checked x0 compare x0))
+         (else (error "bad index" k))))
+      ((compare k x0 x1)
+       (case (modulo k 2)
+         ((0) (if<=? (compare x0 x1) x0 x1))
+         ((1) (if<=? (compare x0 x1) x1 x0))
+         (else (error "bad index" k))))
+      ((compare k x0 x1 x2)
+       (case (modulo k 3)
+         ((0) (if<=? (compare x0 x1)
+                     (if<=? (compare x0 x2) x0 x2)
+                     (if<=? (compare x1 x2) x1 x2)))
+         ((1) (if3 (compare x0 x1)
+                   (if<=? (compare x1 x2)
+                          x1
+                          (if<=? (compare x0 x2) x2 x0))
+                   (if<=? (compare x0 x2) x1 x0)
+                   (if<=? (compare x0 x2)
+                          x0
+                          (if<=? (compare x1 x2) x2 x1))))
+         ((2) (if<=? (compare x0 x1)
+                     (if<=? (compare x1 x2) x2 x1)
+                     (if<=? (compare x0 x2) x2 x0)))
+         (else (error "bad index" k))))
+      ((compare k x0 . x1+) ; |x1+| >= 1
+       (if (not (and (integer? k) (exact? k)))
+           (error "bad index" k))
+       (let ((n (+ 1 (length x1+))))
+         (let kth ((k   (modulo k n))
+                   (n   n)  ; = |x|
+                   (rev #t) ; are x<, x=, x> reversed?
+                   (x   (cons x0 x1+)))
+           (let ((pivot (list-ref x (random-integer n))))
+             (let split ((x x) (x< '()) (n< 0) (x= '()) (n= 0) (x> '()) (n> 0))
+               (if (null? x)
+                   (cond
+                     ((< k n<)
+                      (kth k n< (not rev) x<))
+                     ((< k (+ n< n=))
+                      (if rev
+                          (list-ref x= (- (- n= 1) (- k n<)))
+                          (list-ref x= (- k n<))))
+                     (else
+                      (kth (- k (+ n< n=)) n> (not rev) x>)))
+                   (if3 (compare (car x) pivot)
+                        (split (cdr x) (cons (car x) x<) (+ n< 1) x= n= x> n>)
+                        (split (cdr x) x< n< (cons (car x) x=) (+ n= 1) x> n>)
+                        (split (cdr x) x< n< x= n= (cons (car x) x>) (+ n> 1))))))))))))
+
+
+; compare functions from predicates
+
+(define compare-by<
+  (case-lambda
+   ((lt)     (lambda (x y) (if (lt x y) -1 (if (lt y x)  1 0))))
+   ((lt x y)               (if (lt x y) -1 (if (lt y x)  1 0)))))
+
+(define compare-by>
+  (case-lambda
+   ((gt)     (lambda (x y) (if (gt x y) 1 (if (gt y x)  -1 0))))
+   ((gt x y)               (if (gt x y) 1 (if (gt y x)  -1 0)))))
+
+(define compare-by<=
+  (case-lambda
+   ((le)     (lambda (x y) (if (le x y) (if (le y x) 0 -1) 1)))
+   ((le x y)               (if (le x y) (if (le y x) 0 -1) 1))))
+
+(define compare-by>=
+  (case-lambda
+   ((ge)     (lambda (x y) (if (ge x y) (if (ge y x) 0 1) -1)))
+   ((ge x y)               (if (ge x y) (if (ge y x) 0 1) -1))))
+
+(define compare-by=/<
+  (case-lambda
+   ((eq lt)     (lambda (x y) (if (eq x y) 0 (if (lt x y) -1 1))))
+   ((eq lt x y)               (if (eq x y) 0 (if (lt x y) -1 1)))))
+
+(define compare-by=/>
+  (case-lambda
+   ((eq gt)     (lambda (x y) (if (eq x y) 0 (if (gt x y) 1 -1))))
+   ((eq gt x y)               (if (eq x y) 0 (if (gt x y) 1 -1)))))
+
+; refine and extend construction
+
+(define-syntax refine-compare
+  (syntax-rules ()
+    ((refine-compare)
+     0)
+    ((refine-compare c1)
+     c1)
+    ((refine-compare c1 c2 cs ...)
+     (if3 c1 -1 (refine-compare c2 cs ...) 1))))
+
+(define-syntax select-compare
+  (syntax-rules (else)
+    ((select-compare x y clause ...)
+     (let ((x-val x) (y-val y))
+       (select-compare (x-val y-val clause ...))))
+    ; used internally: (select-compare (x y clause ...))
+    ((select-compare (x y))
+     0)
+    ((select-compare (x y (else c ...)))
+     (refine-compare c ...))
+    ((select-compare (x y (t? c ...) clause ...))
+     (let ((t?-val t?))
+       (let ((tx (t?-val x)) (ty (t?-val y)))
+         (if tx
+             (if ty (refine-compare c ...) -1)
+             (if ty 1 (select-compare (x y clause ...)))))))))
+
+(define-syntax cond-compare
+  (syntax-rules (else)
+    ((cond-compare)
+     0)
+    ((cond-compare (else cs ...))
+     (refine-compare cs ...))
+    ((cond-compare ((tx ty) cs ...) clause ...)
+     (let ((tx-val tx) (ty-val ty))
+       (if tx-val
+           (if ty-val (refine-compare cs ...) -1)
+           (if ty-val 1 (cond-compare clause ...)))))))
+
+
+; R5RS atomic types
+
+(define-syntax compare:type-check
+  (syntax-rules ()
+    ((compare:type-check type? type-name x)
+     (if (not (type? x))
+         (error (string-append "not " type-name ":") x)))
+    ((compare:type-check type? type-name x y)
+     (begin (compare:type-check type? type-name x)
+            (compare:type-check type? type-name y)))))
+
+(define-syntax compare:define-by=/<
+  (syntax-rules ()
+    ((compare:define-by=/< compare = < type? type-name)
+     (define compare
+       (let ((= =) (< <))
+	 (lambda (x y)
+	   (if (type? x)
+	       (if (eq? x y)
+		   0
+		   (if (type? y)
+		       (if (= x y) 0 (if (< x y) -1 1))
+		       (error (string-append "not " type-name ":") y)))
+	       (error (string-append "not " type-name ":") x))))))))
+
+(define (boolean-compare x y)
+  (compare:type-check boolean? "boolean" x y)
+  (if x (if y 0 1) (if y -1 0)))
+
+(compare:define-by=/< char-compare char=? char<? char? "char")
+
+(compare:define-by=/< char-compare-ci char-ci=? char-ci<? char? "char")
+
+(compare:define-by=/< string-compare string=? string<? string? "string")
+
+(compare:define-by=/< string-compare-ci string-ci=? string-ci<? string? "string")
+
+(define (symbol-compare x y)
+  (compare:type-check symbol? "symbol" x y)
+  (string-compare (symbol->string x) (symbol->string y)))
+
+(compare:define-by=/< integer-compare = < integer? "integer")
+
+(compare:define-by=/< rational-compare = < rational? "rational")
+
+(compare:define-by=/< real-compare = < real? "real")
+
+(define (complex-compare x y)
+  (compare:type-check complex? "complex" x y)
+  (if (and (real? x) (real? y))
+      (real-compare x y)
+      (refine-compare (real-compare (real-part x) (real-part y))
+                      (real-compare (imag-part x) (imag-part y)))))
+
+(define (number-compare x y)
+  (compare:type-check number? "number" x y)
+  (complex-compare x y))
+
+
+; R5RS compound data structures: dotted pair, list, vector
+
+(define (pair-compare-car compare)
+  (lambda (x y)
+    (compare (car x) (car y))))
+
+(define (pair-compare-cdr compare)
+  (lambda (x y)
+    (compare (cdr x) (cdr y))))
+
+(define pair-compare
+  (case-lambda
+    
+    ; dotted pair
+    ((pair-compare-car pair-compare-cdr x y)
+     (refine-compare (pair-compare-car (car x) (car y))
+                     (pair-compare-cdr (cdr x) (cdr y))))
+    
+    ; possibly improper lists
+    ((compare x y)
+     (cond-compare 
+      (((null? x) (null? y)) 0)
+      (((pair? x) (pair? y)) (compare              (car x) (car y))
+                             (pair-compare compare (cdr x) (cdr y)))
+      (else                  (compare x y))))
+    
+    ; for convenience
+    ((x y)
+     (pair-compare default-compare x y))))
+
+(define list-compare
+  (case-lambda
+    ((compare x y empty? head tail)
+     (cond-compare
+      (((empty? x) (empty? y)) 0)
+      (else (compare              (head x) (head y))
+            (list-compare compare (tail x) (tail y) empty? head tail))))
+    
+    ; for convenience
+    ((        x y empty? head tail)
+     (list-compare default-compare x y empty? head tail))
+    ((compare x y              )
+     (list-compare compare         x y null? car   cdr))
+    ((        x y              )
+     (list-compare default-compare x y null? car   cdr))))
+
+(define list-compare-as-vector
+  (case-lambda
+    ((compare x y empty? head tail)
+     (refine-compare
+      (let compare-length ((x x) (y y))
+        (cond-compare
+         (((empty? x) (empty? y)) 0)
+         (else (compare-length (tail x) (tail y)))))
+      (list-compare compare x y empty? head tail)))
+    
+    ; for convenience
+    ((        x y empty? head tail)
+     (list-compare-as-vector default-compare x y empty? head tail))
+    ((compare x y              )
+     (list-compare-as-vector compare         x y null?  car  cdr))
+    ((        x y              )
+     (list-compare-as-vector default-compare x y null?  car  cdr))))
+
+(define vector-compare
+  (let ((= =))
+    (case-lambda
+      ((compare x y size ref)
+       (let ((n (size x)) (m (size y)))
+         (refine-compare 
+          (integer-compare n m)
+          (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+            (if (= i n)
+                0
+                (refine-compare (compare (ref x i) (ref y i))
+                                (compare-rest (+ i 1))))))))
+      
+      ; for convenience
+      ((        x y size ref)
+       (vector-compare default-compare x y size          ref))
+      ((compare x y           )
+       (vector-compare compare         x y vector-length vector-ref))
+      ((        x y           )
+       (vector-compare default-compare x y vector-length vector-ref)))))
+
+(define vector-compare-as-list
+  (let ((= =))
+    (case-lambda
+      ((compare x y size ref)
+       (let ((nx (size x)) (ny (size y)))
+         (let ((n (min nx ny)))
+           (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1]
+             (if (= i n)
+                 (integer-compare nx ny)
+                 (refine-compare (compare (ref x i) (ref y i))
+                                 (compare-rest (+ i 1))))))))
+      
+      ; for convenience
+      ((        x y size ref)
+       (vector-compare-as-list default-compare x y size          ref))
+      ((compare x y           )
+       (vector-compare-as-list compare         x y vector-length vector-ref))
+      ((        x y           )
+       (vector-compare-as-list default-compare x y vector-length vector-ref)))))
+
+
+; default compare
+
+(define (default-compare x y)
+  (select-compare 
+   x y
+   (null?    0)
+   (pair?    (default-compare (car x) (car y))
+	     (default-compare (cdr x) (cdr y)))
+   (boolean? (boolean-compare x y))
+   (char?    (char-compare    x y))
+   (string?  (string-compare  x y))
+   (symbol?  (symbol-compare  x y))
+   (number?  (number-compare  x y))
+   (vector?  (vector-compare default-compare x y))
+   (else (error "unrecognized type in default-compare" x y))))
+
+; Note that we pass default-compare to compare-{pair,vector} explictly.
+; This makes sure recursion proceeds with this default-compare, which 
+; need not be the one in the lexical scope of compare-{pair,vector}.
+
+
+; debug compare
+
+(define (debug-compare c)
+  
+  (define (checked-value c x y)
+    (let ((c-xy (c x y)))
+      (if (or (eqv? c-xy -1) (eqv? c-xy 0) (eqv? c-xy 1))
+          c-xy
+          (error "compare value not in {-1,0,1}" c-xy (list c x y)))))
+  
+  (define (random-boolean)
+    (zero? (random-integer 2)))
+  
+  (define q ; (u v w) such that u <= v, v <= w, and not u <= w
+    '#(
+       ;x < y   x = y   x > y   [x < z]
+       0       0       0    ; y < z
+               0    (z y x) (z y x) ; y = z
+               0    (z y x) (z y x) ; y > z
+               
+               ;x < y   x = y   x > y   [x = z]
+               (y z x) (z x y)    0    ; y < z
+               (y z x)    0    (x z y) ; y = z
+               0    (y x z) (x z y) ; y > z
+               
+               ;x < y   x = y   x > y   [x > z]
+               (x y z) (x y z)    0    ; y < z
+               (x y z) (x y z)    0    ; y = z
+               0       0       0    ; y > z
+               ))
+  
+  (let ((z? #f) (z #f)) ; stored element from previous call
+    (lambda (x y)
+      (let ((c-xx (checked-value c x x))
+	    (c-yy (checked-value c y y))
+	    (c-xy (checked-value c x y))
+	    (c-yx (checked-value c y x)))
+	(if (not (zero? c-xx))
+	    (error "compare error: not reflexive" c x))
+	(if (not (zero? c-yy))
+	    (error "compare error: not reflexive" c y))
+	(if (not (zero? (+ c-xy c-yx)))
+	    (error "compare error: not anti-symmetric" c x y))
+	(if z?
+	    (let ((c-xz (checked-value c x z))
+		  (c-zx (checked-value c z x))
+		  (c-yz (checked-value c y z))
+		  (c-zy (checked-value c z y)))
+	      (if (not (zero? (+ c-xz c-zx)))
+		  (error "compare error: not anti-symmetric" c x z))
+	      (if (not (zero? (+ c-yz c-zy)))
+		  (error "compare error: not anti-symmetric" c y z))
+	      (let ((ijk (vector-ref q (+ c-xy (* 3 c-yz) (* 9 c-xz) 13))))
+		(if (list? ijk)
+		    (apply error
+			   "compare error: not transitive"
+			   c 
+			   (map (lambda (i) (case i ((x) x) ((y) y) ((z) z)))
+				ijk)))))
+	    (set! z? #t))
+	(set! z (if (random-boolean) x y)) ; randomized testing
+	c-xy))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index a481260..71094e4 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -121,6 +121,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-39.test			\
 	    tests/srfi-42.test			\
 	    tests/srfi-60.test			\
+	    tests/srfi-67.test			\
 	    tests/srfi-69.test			\
 	    tests/srfi-88.test			\
 	    tests/srfi-4.test			\
diff --git a/test-suite/tests/srfi-67.test b/test-suite/tests/srfi-67.test
new file mode 100644
index 0000000..e5a4471
--- /dev/null
+++ b/test-suite/tests/srfi-67.test
@@ -0,0 +1,1221 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
+;;; 
+;;; This code is based on the file examples.scm in the reference
+;;; implementation of SRFI-67, provided under the following license:
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining
+;;; a copy of this software and associated documentation files (the
+;;; ``Software''), to deal in the Software without restriction, including
+;;; without limitation the rights to use, copy, modify, merge, publish,
+;;; distribute, sublicense, and/or sell copies of the Software, and to
+;;; permit persons to whom the Software is furnished to do so, subject to
+;;; the following conditions:
+;;; 
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;; 
+;;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;;; 
+
+(define-module (test-srfi-67)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-42)
+  #:use-module (srfi srfi-67))
+
+; =============================================================================
+
+; Test engine
+; ===========
+;
+; We use an extended version of the the checker of SRFI-42 (with
+; Felix' reduction on codesize) for running a batch of tests for
+; the various procedures of 'compare.scm'. Moreover, we use the
+; comprehensions of SRFI-42 to generate examples systematically.
+
+; (my-check expr => desired-result)
+;   evaluates expr and compares the value with desired-result.
+
+(define-syntax my-check
+  (syntax-rules (=>)
+    ((my-check expr => desired-result)
+     (my-check-proc 'expr (lambda () expr) desired-result))))
+
+(define (my-check-proc expr thunk desired-result)
+  (pass-if expr (equal? (thunk) desired-result)))
+
+; (my-check-ec <qualifier>* <ok?> <expr>)
+;    runs (every?-ec <qualifier>* <ok?>), counting the times <ok?>
+;    is evaluated as a correct example, and stopping at the first
+;    counter example for which <expr> provides the argument.
+
+(define-syntax my-check-ec
+  (syntax-rules (nested)
+    ((my-check-ec (nested q1 ...) q etc1 etc2 etc ...)
+     (my-check-ec (nested q1 ... q) etc1 etc2 etc ...))
+    ((my-check-ec q1 q2             etc1 etc2 etc ...)
+     (my-check-ec (nested q1 q2)    etc1 etc2 etc ...))
+    ((my-check-ec ok? expr)
+     (my-check-ec (nested) ok? expr))
+    ((my-check-ec (nested q ...) ok? expr)
+     (my-check-ec-proc
+      '(every?-ec q ... ok?)
+      (lambda ()
+        (first-ec 
+         'ok
+         (nested q ...)
+         (:let ok ok?)
+         (if (not ok))
+         (list expr)))
+      'expr))
+    ((my-check-ec q ok? expr)
+     (my-check-ec (nested q) ok? expr))))
+
+(define (my-check-ec-proc expr thunk arg-counter-example)
+  (pass-if expr (eqv? (thunk) 'ok)))
+
+; =============================================================================
+
+; Abstractions etc.
+; =================
+
+(define ci integer-compare) ; very frequently used
+
+; (result-ok? actual desired)
+;   tests if actual and desired specify the same ordering.
+
+(define (result-ok? actual desired)
+  (eqv? actual desired))
+
+; (my-check-compare compare increasing-elements)
+;    evaluates (compare x y) for x, y in increasing-elements
+;    and checks the result against -1, 0, or 1 depending on
+;    the position of x and y in the list increasing-elements.
+
+(define-syntax my-check-compare
+  (syntax-rules ()
+    ((my-check-compare compare increasing-elements)
+     (my-check-ec
+      (:list x (index ix) increasing-elements)
+      (:list y (index iy) increasing-elements)
+      (result-ok? (compare x y) (ci ix iy))
+      (list x y)))))
+
+; sorted lists
+
+(define my-booleans   '(#f #t))
+(define my-chars      '(#\a #\b #\c))
+(define my-chars-ci   '(#\a #\B #\c #\D))
+(define my-strings    '("" "a" "aa" "ab" "b" "ba" "bb"))
+(define my-strings-ci '("" "a" "aA" "Ab" "B" "bA" "BB"))
+(define my-symbols    '(a aa ab b ba bb))
+
+(define my-reals
+  (append-ec (:range xn -6 7) 
+             (:let x (/ xn 3))
+             (list x (+ x (exact->inexact (/ 1 100))))))
+
+(define my-rationals
+  (list-ec (:list x my-reals)
+           (and (exact? x) (rational? x))
+           x))
+
+(define my-integers
+  (list-ec (:list x my-reals)
+           (if (and (exact? x) (integer? x)))
+           x))
+
+(define my-complexes
+  (list-ec (:list re-x my-reals)
+           (if (inexact? re-x))
+           (:list im-x my-reals)
+           (if (inexact? im-x))
+           (make-rectangular re-x im-x)))
+
+(define my-lists
+  '(() (1) (1 1) (1 2) (2) (2 1) (2 2)))
+
+(define my-vector-as-lists
+  (map list->vector my-lists))
+
+(define my-list-as-vectors
+  '(() (1) (2) (1 1) (1 2) (2 1) (2 2)))
+
+(define my-vectors
+  (map list->vector my-list-as-vectors))
+
+(define my-null-or-pairs 
+  '(()
+    (1) (1 1) (1 2) (1 . 1) (1 . 2) 
+    (2) (2 1) (2 2) (2 . 1) (2 . 2)))
+
+(define my-objects
+  (append my-null-or-pairs
+          my-booleans
+          my-chars
+          my-strings
+          my-symbols
+          my-integers
+          my-vectors))
+
+; =============================================================================
+
+; The checks
+; ==========
+
+(define (check:if3)
+  
+  ; basic functionality
+  
+  (my-check (if3 -1 'n 'z 'p) => 'n)
+  (my-check (if3  0 'n 'z 'p) => 'z)
+  (my-check (if3  1 'n 'z 'p) => 'p)
+  
+  ; check arguments are evaluated only once
+  
+  (my-check 
+   (let ((x -1))
+     (if3 (let ((x0 x)) (set! x (+ x 1)) x0) 'n 'z 'p))
+   => 'n)
+  
+  (my-check 
+   (let ((x -1) (y 0)) 
+     (if3 (let ((x0 x)) (set! x (+ x 1)) x0)
+          (begin (set! y (+ y 1))   y)
+          (begin (set! y (+ y 10))  y)
+          (begin (set! y (+ y 100)) y)))
+   => 1)
+  
+  (my-check 
+   (let ((x 0) (y 0)) 
+     (if3 (let ((x0 x)) (set! x (+ x 1)) x0)
+          (begin (set! y (+ y 1))   y)
+          (begin (set! y (+ y 10))  y)
+          (begin (set! y (+ y 100)) y)))
+   => 10)
+  
+  (my-check 
+   (let ((x 1) (y 0)) 
+     (if3 (let ((x0 x)) (set! x (+ x 1)) x0)
+          (begin (set! y (+ y 1))   y)
+          (begin (set! y (+ y 10))  y)
+          (begin (set! y (+ y 100)) y)))
+   => 100)
+  
+  ) ; check:if3
+
+(define-syntax my-check-if2
+  (syntax-rules ()
+    ((my-check-if2 if-rel? rel)
+     (begin
+       ; check result
+       (my-check (if-rel? -1 'yes 'no) => (if (rel -1 0) 'yes 'no))
+       (my-check (if-rel?  0 'yes 'no) => (if (rel  0 0) 'yes 'no))
+       (my-check (if-rel?  1 'yes 'no) => (if (rel  1 0) 'yes 'no))
+       
+       ; check result of 'laterally challenged if'
+       (my-check (let ((x #f)) (if-rel? -1 (set! x #t)) x) => (rel -1 0))
+       (my-check (let ((x #f)) (if-rel?  0 (set! x #t)) x) => (rel  0 0))
+       (my-check (let ((x #f)) (if-rel?  1 (set! x #t)) x) => (rel  1 0))
+       
+       ; check that <c> is evaluated exactly once
+       (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) -1) #t #f) n) => 1)
+       (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1))  0) #t #f) n) => 1)
+       (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1))  1) #t #f) n) => 1)
+       (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) -1) #t) n) => 1)
+       (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1))  0) #t) n) => 1)
+       (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1))  1) #t) n) => 1)
+       ))))
+
+(define (check:ifs)
+  
+  (my-check-if2 if=?     =)
+  (my-check-if2 if<?     <)
+  (my-check-if2 if>?     >)
+  (my-check-if2 if<=?    <=)
+  (my-check-if2 if>=?    >=)
+  (my-check-if2 if-not=? (lambda (x y) (not (= x y))))
+  
+  ) ; check:if2
+
+; <? etc. macros
+
+(define-syntax my-check-chain2
+  (syntax-rules ()
+    ((my-check-chain2 rel? rel)
+     (begin
+       ; all chains of length 2
+       (my-check (rel? ci 0 0) => (rel 0 0))
+       (my-check (rel? ci 0 1) => (rel 0 1))
+       (my-check (rel? ci 1 0) => (rel 1 0))
+       
+       ; using default-compare
+       (my-check (rel? 0 0) => (rel 0 0))
+       (my-check (rel? 0 1) => (rel 0 1))
+       (my-check (rel? 1 0) => (rel 1 0))
+
+       ; as a combinator
+       (my-check ((rel? ci) 0 0) => (rel 0 0))
+       (my-check ((rel? ci) 0 1) => (rel 0 1))
+       (my-check ((rel? ci) 1 0) => (rel 1 0))
+
+       ; using default-compare as a combinator
+       (my-check ((rel?) 0 0) => (rel 0 0))
+       (my-check ((rel?) 0 1) => (rel 0 1))
+       (my-check ((rel?) 1 0) => (rel 1 0))
+       ))))
+
+(define (list->set xs) ; xs a list of integers
+  (if (null? xs)
+      '()
+      (let ((max-xs
+             (let max-without-apply ((m 1) (xs xs))
+               (if (null? xs)
+                   m
+                   (max-without-apply (max m (car xs)) (cdr xs))))))
+        (let ((in-xs? (make-vector (+ max-xs 1) #f)))
+          (do-ec (:list x xs) (vector-set! in-xs? x #t))
+          (list-ec (:vector in? (index x) in-xs?)
+                   (if in?)
+                   x)))))
+
+(define-syntax arguments-used ; set of arguments (integer, >=0) used in compare
+  (syntax-rules ()
+    ((arguments-used (rel1/rel2 compare arg ...))
+     (let ((used '()))
+       (rel1/rel2 (lambda (x y)
+                    (set! used (cons x (cons y used)))
+                    (compare x y))
+                  arg ...)
+       (list->set used)))))
+
+(define-syntax my-check-chain3
+  (syntax-rules ()
+    ((my-check-chain3 rel1/rel2? rel1 rel2)
+     (begin     
+       ; all chains of length 3
+       (my-check (rel1/rel2? ci 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
+       (my-check (rel1/rel2? ci 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
+       (my-check (rel1/rel2? ci 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
+       (my-check (rel1/rel2? ci 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
+       (my-check (rel1/rel2? ci 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
+       (my-check (rel1/rel2? ci 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
+       (my-check (rel1/rel2? ci 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
+       (my-check (rel1/rel2? ci 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
+       (my-check (rel1/rel2? ci 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
+       (my-check (rel1/rel2? ci 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
+       (my-check (rel1/rel2? ci 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
+       (my-check (rel1/rel2? ci 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
+       (my-check (rel1/rel2? ci 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
+       
+       ; using default-compare
+       (my-check (rel1/rel2? 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
+       (my-check (rel1/rel2? 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
+       (my-check (rel1/rel2? 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
+       (my-check (rel1/rel2? 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
+       (my-check (rel1/rel2? 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
+       (my-check (rel1/rel2? 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
+       (my-check (rel1/rel2? 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
+       (my-check (rel1/rel2? 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
+       (my-check (rel1/rel2? 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
+       (my-check (rel1/rel2? 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
+       (my-check (rel1/rel2? 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
+       (my-check (rel1/rel2? 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
+       (my-check (rel1/rel2? 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
+       
+       ; as a combinator
+       (my-check ((rel1/rel2? ci) 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
+       (my-check ((rel1/rel2? ci) 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
+       (my-check ((rel1/rel2? ci) 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
+       (my-check ((rel1/rel2? ci) 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
+       (my-check ((rel1/rel2? ci) 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
+       (my-check ((rel1/rel2? ci) 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
+       (my-check ((rel1/rel2? ci) 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
+       (my-check ((rel1/rel2? ci) 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
+       (my-check ((rel1/rel2? ci) 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
+       (my-check ((rel1/rel2? ci) 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
+       (my-check ((rel1/rel2? ci) 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
+       (my-check ((rel1/rel2? ci) 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
+       (my-check ((rel1/rel2? ci) 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
+
+       ; as a combinator using default-compare
+       (my-check ((rel1/rel2?) 0 0 0) => (and (rel1 0 0) (rel2 0 0)))
+       (my-check ((rel1/rel2?) 0 0 1) => (and (rel1 0 0) (rel2 0 1)))
+       (my-check ((rel1/rel2?) 0 1 0) => (and (rel1 0 1) (rel2 1 0)))
+       (my-check ((rel1/rel2?) 1 0 0) => (and (rel1 1 0) (rel2 0 0)))
+       (my-check ((rel1/rel2?) 1 1 0) => (and (rel1 1 1) (rel2 1 0)))
+       (my-check ((rel1/rel2?) 1 0 1) => (and (rel1 1 0) (rel2 0 1)))
+       (my-check ((rel1/rel2?) 0 1 1) => (and (rel1 0 1) (rel2 1 1)))
+       (my-check ((rel1/rel2?) 0 1 2) => (and (rel1 0 1) (rel2 1 2)))
+       (my-check ((rel1/rel2?) 0 2 1) => (and (rel1 0 2) (rel2 2 1)))
+       (my-check ((rel1/rel2?) 1 2 0) => (and (rel1 1 2) (rel2 2 0)))
+       (my-check ((rel1/rel2?) 1 0 2) => (and (rel1 1 0) (rel2 0 2)))
+       (my-check ((rel1/rel2?) 2 0 1) => (and (rel1 2 0) (rel2 0 1)))
+       (my-check ((rel1/rel2?) 2 1 0) => (and (rel1 2 1) (rel2 1 0)))
+       
+       ; test if all arguments are type checked
+       (my-check (arguments-used (rel1/rel2? ci 0 1 2)) => '(0 1 2))
+       (my-check (arguments-used (rel1/rel2? ci 0 2 1)) => '(0 1 2))
+       (my-check (arguments-used (rel1/rel2? ci 1 2 0)) => '(0 1 2))
+       (my-check (arguments-used (rel1/rel2? ci 1 0 2)) => '(0 1 2))
+       (my-check (arguments-used (rel1/rel2? ci 2 0 1)) => '(0 1 2))
+       (my-check (arguments-used (rel1/rel2? ci 2 1 0)) => '(0 1 2))
+       ))))
+
+(define-syntax my-check-chain
+  (syntax-rules ()
+    ((my-check-chain chain-rel? rel)
+     (begin
+       ; the chain of length 0
+       (my-check (chain-rel? ci) => #t)
+       
+       ; a chain of length 1
+       (my-check (chain-rel? ci 0) => #t)
+       
+       ; all chains of length 2
+       (my-check (chain-rel? ci 0 0) => (rel 0 0))
+       (my-check (chain-rel? ci 0 1) => (rel 0 1))
+       (my-check (chain-rel? ci 1 0) => (rel 1 0))
+       
+       ; all chains of length 3
+       (my-check (chain-rel? ci 0 0 0) => (rel 0 0 0))
+       (my-check (chain-rel? ci 0 0 1) => (rel 0 0 1))
+       (my-check (chain-rel? ci 0 1 0) => (rel 0 1 0))
+       (my-check (chain-rel? ci 1 0 0) => (rel 1 0 0))
+       (my-check (chain-rel? ci 1 1 0) => (rel 1 1 0))
+       (my-check (chain-rel? ci 1 0 1) => (rel 1 0 1))
+       (my-check (chain-rel? ci 0 1 1) => (rel 0 1 1))
+       (my-check (chain-rel? ci 0 1 2) => (rel 0 1 2))
+       (my-check (chain-rel? ci 0 2 1) => (rel 0 2 1))
+       (my-check (chain-rel? ci 1 2 0) => (rel 1 2 0))
+       (my-check (chain-rel? ci 1 0 2) => (rel 1 0 2))
+       (my-check (chain-rel? ci 2 0 1) => (rel 2 0 1))
+       (my-check (chain-rel? ci 2 1 0) => (rel 2 1 0))
+       
+       ; check if all arguments are used
+       (my-check (arguments-used (chain-rel? ci 0)) => '(0))
+       (my-check (arguments-used (chain-rel? ci 0 1)) => '(0 1))
+       (my-check (arguments-used (chain-rel? ci 1 0)) => '(0 1))
+       (my-check (arguments-used (chain-rel? ci 0 1 2)) => '(0 1 2))
+       (my-check (arguments-used (chain-rel? ci 0 2 1)) => '(0 1 2))
+       (my-check (arguments-used (chain-rel? ci 1 2 0)) => '(0 1 2))
+       (my-check (arguments-used (chain-rel? ci 1 0 2)) => '(0 1 2))
+       (my-check (arguments-used (chain-rel? ci 2 0 1)) => '(0 1 2))
+       (my-check (arguments-used (chain-rel? ci 2 1 0)) => '(0 1 2))
+       ))))
+
+(define (check:predicates-from-compare)
+  
+  (my-check-chain2 =?    =)
+  (my-check-chain2 <?    <)
+  (my-check-chain2 >?    >)
+  (my-check-chain2 <=?   <=)
+  (my-check-chain2 >=?   >=)
+  (my-check-chain2 not=? (lambda (x y) (not (= x y))))
+  
+  (my-check-chain3 </<?   <  <)
+  (my-check-chain3 </<=?  <  <=)
+  (my-check-chain3 <=/<?  <= <)
+  (my-check-chain3 <=/<=? <= <=)
+  
+  (my-check-chain3 >/>?   >  >)
+  (my-check-chain3 >/>=?  >  >=)
+  (my-check-chain3 >=/>?  >= >)
+  (my-check-chain3 >=/>=? >= >=)
+  
+  (my-check-chain chain=?  =)
+  (my-check-chain chain<?  <)
+  (my-check-chain chain>?  >)
+  (my-check-chain chain<=? <=)
+  (my-check-chain chain>=? >=)
+  
+  ) ; check:predicates-from-compare
+
+; pairwise-not=?
+
+(define pairwise-not=?:long-sequences
+  (let ()
+    
+    (define (extremal-pivot-sequence r)
+      ; The extremal pivot sequence of order r is a 
+      ; permutation of {0..2^(r+1)-2} such that the
+      ; middle element is minimal, and this property
+      ; holds recursively for each binary subdivision.
+      ;   This sequence exposes a naive implementation of
+      ; pairwise-not=? chosing the middle element as pivot.
+      (if (zero? r)
+          '(0)
+          (let* ((s (extremal-pivot-sequence (- r 1)))
+                 (ns (length s)))
+            (append (list-ec (:list x s) (+ x 1))
+                    '(0)
+                    (list-ec (:list x s) (+ x ns 1))))))
+    
+    (list (list-ec (: i 4096) i)
+          (list-ec (: i 4097 0 -1) i)
+          (list-ec (: i 4099) (modulo (* 1003 i) 4099))
+          (extremal-pivot-sequence 11))))
+
+(define pairwise-not=?:short-sequences
+  (let ()
+    
+    (define (combinations/repeats n l)
+      ; return list of all sublists of l of size n,
+      ; the order of the elements occur in the sublists 
+      ; of the output is the same as in the input
+      (let ((len (length l)))
+        (cond
+          ((= n 0)   '())
+          ((= n 1)   (map list l))
+          ((= len 1) (do ((r '() (cons (car l) r))
+                          (i n (- i 1)))
+                       ((= i 0) (list r))))
+          (else      (append (combinations/repeats n (cdr l))
+                             (map (lambda (c) (cons (car l) c))
+                                  (combinations/repeats (- n 1) l)))))))
+    
+    (define (permutations l)
+      ; return a list of all permutations of l
+      (let ((len (length l)))
+        (cond
+          ((= len 0) '(()))
+          ((= len 1) (list l))
+          (else      (apply append
+                            (map (lambda (p) (insert-every-where (car l) p))
+                                 (permutations (cdr l))))))))      
+    
+    (define (insert-every-where x xs)
+      (let loop ((result '()) (before '()) (after  xs))
+        (let ((new (append before (cons x after))))
+          (cond
+            ((null? after) (cons new result))
+            (else          (loop (cons new result)
+                                 (append before (list (car after)))
+                                 (cdr after))))))) 
+    
+    (define (sequences n max)
+      (apply append
+             (map permutations
+                  (combinations/repeats n (list-ec (: i max) i)))))
+    
+    (append-ec (: n 5) (sequences n 5))))
+
+(define (colliding-compare x y)
+  (ci (modulo x 3) (modulo y 3)))
+
+(define (naive-pairwise-not=? compare . xs)
+  (let ((xs (list->vector xs)))
+    (every?-ec (:range i (- (vector-length xs) 1))
+               (:let xs-i (vector-ref xs i))
+               (:range j (+ i 1) (vector-length xs))
+               (:let xs-j (vector-ref xs j))
+               (not=? compare xs-i xs-j))))
+
+(define (check:pairwise-not=?)
+  
+  ; 0-ary, 1-ary
+  (my-check (pairwise-not=? ci)   => #t)
+  (my-check (pairwise-not=? ci 0) => #t)
+  
+  ; 2-ary
+  (my-check (pairwise-not=? ci 0 0) => #f)
+  (my-check (pairwise-not=? ci 0 1) => #t)
+  (my-check (pairwise-not=? ci 1 0) => #t)
+  
+  ; 3-ary
+  (my-check (pairwise-not=? ci 0 0 0) => #f)
+  (my-check (pairwise-not=? ci 0 0 1) => #f)
+  (my-check (pairwise-not=? ci 0 1 0) => #f)
+  (my-check (pairwise-not=? ci 1 0 0) => #f)
+  (my-check (pairwise-not=? ci 1 1 0) => #f)
+  (my-check (pairwise-not=? ci 1 0 1) => #f)
+  (my-check (pairwise-not=? ci 0 1 1) => #f)
+  (my-check (pairwise-not=? ci 0 1 2) => #t)
+  (my-check (pairwise-not=? ci 0 2 1) => #t)
+  (my-check (pairwise-not=? ci 1 2 0) => #t)
+  (my-check (pairwise-not=? ci 1 0 2) => #t)
+  (my-check (pairwise-not=? ci 2 0 1) => #t)
+  (my-check (pairwise-not=? ci 2 1 0) => #t)
+  
+  ; n-ary, n large: [0..n-1], [n,n-1..1], 5^[0..96] mod 97
+  (my-check (apply pairwise-not=? ci (list-ec (: i 10) i)) => #t)
+  (my-check (apply pairwise-not=? ci (list-ec (: i 100) i)) => #t)
+  (my-check (apply pairwise-not=? ci (list-ec (: i 1000) i)) => #t)
+  
+  (my-check (apply pairwise-not=? ci (list-ec (: i 10 0 -1) i)) => #t)
+  (my-check (apply pairwise-not=? ci (list-ec (: i 100 0 -1) i)) => #t)
+  (my-check (apply pairwise-not=? ci (list-ec (: i 1000 0 -1) i)) => #t)
+  
+  (my-check (apply pairwise-not=? ci 
+                   (list-ec (: i 97) (modulo (* 5 i) 97)))
+            => #t)
+  
+  ; bury another copy of 72 = 5^50 mod 97 in 5^[0..96] mod 97
+  (my-check (apply pairwise-not=? ci 
+                   (append (list-ec (: i 0 23) (modulo (* 5 i) 97))
+                           '(72)
+                           (list-ec (: i 23 97) (modulo (* 5 i) 97))))
+            => #f)
+  (my-check (apply pairwise-not=? ci 
+                   (append (list-ec (: i 0 75) (modulo (* 5 i) 97))
+                           '(72)
+                           (list-ec (: i 75 97) (modulo (* 5 i) 97))))
+            => #f)
+  
+  ; check if all arguments are used
+  (my-check (arguments-used (pairwise-not=? ci 0)) => '(0))
+  (my-check (arguments-used (pairwise-not=? ci 0 1)) => '(0 1))
+  (my-check (arguments-used (pairwise-not=? ci 1 0)) => '(0 1))
+  (my-check (arguments-used (pairwise-not=? ci 0 2 1)) => '(0 1 2))
+  (my-check (arguments-used (pairwise-not=? ci 1 2 0)) => '(0 1 2))
+  (my-check (arguments-used (pairwise-not=? ci 1 0 2)) => '(0 1 2))
+  (my-check (arguments-used (pairwise-not=? ci 2 0 1)) => '(0 1 2))
+  (my-check (arguments-used (pairwise-not=? ci 2 1 0)) => '(0 1 2))
+  (my-check (arguments-used (pairwise-not=? ci 0 0 0 1 0 0 0 2 0 0 0 3))
+            => '(0 1 2 3))
+  
+  ; Guess if the implementation is O(n log n):
+  ;   The test is run for 2^e pairwise unequal inputs, e >= 1,
+  ;   and the number of calls to the compare procedure is counted.
+  ;     all pairs:          A = Binomial[2^e, 2] = 2^(2 e - 1) * (1 - 2^-e).
+  ;     divide and conquer: D = e 2^e.
+  ;   Since an implementation can be randomized, the actual count may
+  ;   be a random number. We put a threshold at 100 e 2^e and choose
+  ;   e such that A/D >= 150, i.e. e >= 12.
+  ;     The test is applied to several inputs that are known to cause
+  ;   trouble in simplistic sorting algorithms: (0..2^e-1), (2^e+1,2^e..1),
+  ;   a pseudo-random permutation, and a sequence with an extremal pivot
+  ;   at the center of each subsequence.
+  
+  (my-check-ec 
+   (:list input pairwise-not=?:long-sequences)
+   (let ((compares 0))
+     (apply pairwise-not=? 
+            (lambda (x y)
+              (set! compares (+ compares 1))
+              (ci x y))
+            input)
+     ;     (display compares) (newline)
+     (< compares (* 100 12 4096)))
+   (length input))
+  
+  ; check many short sequences
+  
+  (my-check-ec 
+   (:list input pairwise-not=?:short-sequences)
+   (eq?
+    (apply pairwise-not=? colliding-compare input)
+    (apply naive-pairwise-not=? colliding-compare input))
+   input)
+  
+  ; check if the arguments are used for short sequences
+  
+  (my-check-ec 
+   (:list input pairwise-not=?:short-sequences)
+   (let ((args '()))
+     (apply pairwise-not=? 
+            (lambda (x y)
+              (set! args (cons x (cons y args)))
+              (colliding-compare x y))
+            input)
+     (equal? (list->set args) (list->set input)))
+   input)
+  
+  ) ; check:pairwise-not=?
+
+
+; min/max
+
+(define min/max:sequences
+  (append pairwise-not=?:short-sequences
+          pairwise-not=?:long-sequences))
+
+(define (check:min/max)
+  
+  ; all lists of length 1,2,3
+  (my-check (min-compare ci 0) => 0)
+  (my-check (min-compare ci 0 0) => 0)
+  (my-check (min-compare ci 0 1) => 0)
+  (my-check (min-compare ci 1 0) => 0)
+  (my-check (min-compare ci 0 0 0) => 0)
+  (my-check (min-compare ci 0 0 1) => 0)
+  (my-check (min-compare ci 0 1 0) => 0)
+  (my-check (min-compare ci 1 0 0) => 0)
+  (my-check (min-compare ci 1 1 0) => 0)
+  (my-check (min-compare ci 1 0 1) => 0)
+  (my-check (min-compare ci 0 1 1) => 0)
+  (my-check (min-compare ci 0 1 2) => 0)
+  (my-check (min-compare ci 0 2 1) => 0)
+  (my-check (min-compare ci 1 2 0) => 0)
+  (my-check (min-compare ci 1 0 2) => 0)
+  (my-check (min-compare ci 2 0 1) => 0)
+  (my-check (min-compare ci 2 1 0) => 0)
+  
+  (my-check (max-compare ci 0) => 0)
+  (my-check (max-compare ci 0 0) => 0)
+  (my-check (max-compare ci 0 1) => 1)
+  (my-check (max-compare ci 1 0) => 1)
+  (my-check (max-compare ci 0 0 0) => 0)
+  (my-check (max-compare ci 0 0 1) => 1)
+  (my-check (max-compare ci 0 1 0) => 1)
+  (my-check (max-compare ci 1 0 0) => 1)
+  (my-check (max-compare ci 1 1 0) => 1)
+  (my-check (max-compare ci 1 0 1) => 1)
+  (my-check (max-compare ci 0 1 1) => 1)
+  (my-check (max-compare ci 0 1 2) => 2)
+  (my-check (max-compare ci 0 2 1) => 2)
+  (my-check (max-compare ci 1 2 0) => 2)
+  (my-check (max-compare ci 1 0 2) => 2)
+  (my-check (max-compare ci 2 0 1) => 2)
+  (my-check (max-compare ci 2 1 0) => 2)
+  
+  ; check that the first minimal value is returned
+  (my-check (min-compare (pair-compare-car ci)
+                         '(0 1) '(0 2) '(0 3))
+            => '(0 1))
+  (my-check (max-compare (pair-compare-car ci)
+                         '(0 1) '(0 2) '(0 3))
+            => '(0 1))
+  
+  ; check for many inputs
+  (my-check-ec 
+   (:list input min/max:sequences)
+   (= (apply min-compare ci input)
+      (apply min (apply max input) input))
+   input)
+  (my-check-ec 
+   (:list input min/max:sequences)
+   (= (apply max-compare ci input)
+      (apply max (apply min input) input))
+   input)
+  ; Note the stupid extra argument in the apply for
+  ; the standard min/max makes sure the elements are
+  ; identical when apply truncates the arglist.
+  
+  ) ; check:min/max
+
+
+; kth-largest
+
+(define kth-largest:sequences
+  pairwise-not=?:short-sequences)
+
+(define (naive-kth-largest compare k . xs)
+  (let ((vec (list->vector xs)))
+    ; bubble sort: simple, stable, O(|xs|^2)
+    (do-ec (:range n (- (vector-length vec) 1))
+           (:range i 0 (- (- (vector-length vec) 1) n))
+           (if>? (compare (vector-ref vec i)
+                          (vector-ref vec (+ i 1)))
+                 (let ((vec-i (vector-ref vec i)))
+                   (vector-set! vec i (vector-ref vec (+ i 1)))
+                   (vector-set! vec (+ i 1) vec-i))))
+    (vector-ref vec (modulo k (vector-length vec)))))
+
+(define (check:kth-largest)
+  
+  ; check extensively against naive-kth-largest
+  (my-check-ec 
+   (:list input kth-largest:sequences)
+   (: k (- -2 (length input)) (+ (length input) 2))
+   (= (apply naive-kth-largest colliding-compare k input)
+      (apply kth-largest colliding-compare k input))
+   (list input k))
+  
+  ) ;check:kth-largest
+
+; compare-by< etc. procedures
+
+(define (check:compare-from-predicates)
+  
+  (my-check-compare
+   (compare-by< <)
+   my-integers)
+  
+  (my-check-compare
+   (compare-by> >)
+   my-integers)
+  
+  (my-check-compare
+   (compare-by<= <=)
+   my-integers)
+  
+  (my-check-compare
+   (compare-by>= >=)
+   my-integers)
+  
+  (my-check-compare
+   (compare-by=/< = <)
+   my-integers)
+  
+  (my-check-compare
+   (compare-by=/> = >)
+   my-integers)
+  
+  ; with explicit arguments
+
+  (my-check-compare
+   (lambda (x y) (compare-by< < x y))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y) (compare-by> > x y))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y) (compare-by<= <= x y))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y) (compare-by>= >= x y))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y) (compare-by=/< = < x y))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y) (compare-by=/> = > x y))
+   my-integers)
+  
+  ) ; check:compare-from-predicates
+
+
+(define (check:atomic)
+  
+  (my-check-compare boolean-compare   my-booleans)
+  
+  (my-check-compare char-compare      my-chars)
+  
+  (my-check-compare char-compare-ci   my-chars-ci)
+  
+  (my-check-compare string-compare    my-strings)
+  
+  (my-check-compare string-compare-ci my-strings-ci)
+  
+  (my-check-compare symbol-compare    my-symbols)
+  
+  (my-check-compare integer-compare   my-integers)
+  
+  (my-check-compare rational-compare  my-rationals)
+  
+  (my-check-compare real-compare      my-reals)
+  
+  (my-check-compare complex-compare   my-complexes)
+  
+  (my-check-compare number-compare    my-complexes)
+  
+  ) ; check:atomic
+
+(define (check:refine-select-cond)
+  
+  ; refine-compare
+  
+  (my-check-compare
+   (lambda (x y) (refine-compare))
+   '(#f))
+  
+  (my-check-compare
+   (lambda (x y) (refine-compare (integer-compare x y)))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y)
+     (refine-compare (integer-compare (car x) (car y))
+                     (symbol-compare  (cdr x) (cdr y))))
+   '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
+  
+  (my-check-compare
+   (lambda (x y)
+     (refine-compare (integer-compare (car   x) (car   y))
+                     (symbol-compare  (cadr  x) (cadr  y))
+                     (string-compare  (caddr x) (caddr y))))
+   '((1 a "a") (1 b "a") (1 b "b") (2 b "c") (2 c "a") (3 a "b") (3 c "b")))
+  
+  ; select-compare
+  
+  (my-check-compare
+   (lambda (x y) (select-compare x y))
+   '(#f))
+  
+  (my-check-compare
+   (lambda (x y)
+     (select-compare x y 
+                     (integer? (ci x y))))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y)
+     (select-compare x y 
+                     (pair? (integer-compare (car x) (car y))
+                            (symbol-compare  (cdr x) (cdr y)))))
+   '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
+  
+  (my-check-compare
+   (lambda (x y)
+     (select-compare x y 
+                     (else (integer-compare x y))))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y)
+     (select-compare x y 
+                     (else (integer-compare (car x) (car y))
+                           (symbol-compare  (cdr x) (cdr y)))))
+   '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
+  
+  (my-check-compare
+   (lambda (x y)
+     (select-compare x y
+                     (symbol? (symbol-compare x y))
+                     (string? (string-compare x y))))
+   '(a b c "a" "b" "c" 1)) ; implicit (else 0)
+  
+  (my-check-compare
+   (lambda (x y)
+     (select-compare x y
+                     (symbol? (symbol-compare x y))
+                     (else    (string-compare x y))))
+   '(a b c "a" "b" "c"))
+  
+  ; test if arguments are only evaluated once
+  
+  (my-check
+   (let ((nx 0) (ny 0) (nt 0))
+     (select-compare (begin (set! nx (+ nx 1)) 1)
+                     (begin (set! ny (+ ny 1)) 2)
+                     ((lambda (z) (set! nt (+ nt   1)) #f) 0)
+                     ((lambda (z) (set! nt (+ nt  10)) #f) 0)
+                     ((lambda (z) (set! nt (+ nt 100)) #f) 0)
+                     (else 0))
+     (list nx ny nt))
+   => '(1 1 222))
+  
+  ; cond-compare
+  
+  (my-check-compare
+   (lambda (x y) (cond-compare))
+   '(#f))
+  
+  (my-check-compare
+   (lambda (x y) 
+     (cond-compare 
+      (((integer? x) (integer? y)) (integer-compare x y))))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y) 
+     (cond-compare 
+      (((pair? x) (pair? y)) (integer-compare (car x) (car y))
+                             (symbol-compare  (cdr x) (cdr y)))))
+   '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
+  
+  (my-check-compare
+   (lambda (x y)
+     (cond-compare
+      (else (integer-compare x y))))
+   my-integers)
+  
+  (my-check-compare
+   (lambda (x y) 
+     (cond-compare 
+      (else (integer-compare (car x) (car y))
+            (symbol-compare  (cdr x) (cdr y)))))
+   '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c)))
+  
+  (my-check-compare
+   (lambda (x y)
+     (cond-compare 
+      (((symbol? x) (symbol? y)) (symbol-compare x y))
+      (((string? x) (string? y)) (string-compare x y))))
+   '(a b c "a" "b" "c" 1)) ; implicit (else 0)
+  
+  (my-check-compare
+   (lambda (x y)
+     (cond-compare 
+      (((symbol? x) (symbol? y)) (symbol-compare x y))
+      (else                      (string-compare x y))))
+   '(a b c "a" "b" "c"))
+  
+  ) ; check:refine-select-cond
+
+
+; We define our own list/vector data structure
+; as '(my-list x[1] .. x[n]), n >= 0, in order
+; to make sure the default ops don't work on it.
+
+(define (my-list-checked obj) 
+  (if (and (list? obj) (eqv? (car obj) 'my-list))
+      obj
+      (error "expected my-list but received" obj)))
+
+(define (list->my-list list) (cons 'my-list list))
+(define (my-empty? x)        (null? (cdr (my-list-checked x))))
+(define (my-head x)          (cadr (my-list-checked x)))
+(define (my-tail x)          (cons 'my-list (cddr (my-list-checked x))))
+(define (my-size x)          (- (length (my-list-checked x)) 1))
+(define (my-ref x i)         (list-ref (my-list-checked x) (+ i 1)))
+
+(define (check:data-structures)
+  
+  (my-check-compare
+   (pair-compare-car ci)
+   '((1 . b) (2 . a) (3 . c)))
+  
+  (my-check-compare
+   (pair-compare-cdr ci)
+   '((b . 1) (a . 2) (c . 3)))
+  
+  ; pair-compare
+  
+  (my-check-compare pair-compare my-null-or-pairs)
+  
+  (my-check-compare
+   (lambda (x y) (pair-compare ci x y))
+   my-null-or-pairs)
+  
+  (my-check-compare
+   (lambda (x y) (pair-compare ci symbol-compare x y))
+   '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a)))
+  
+  ; list-compare
+  
+  (my-check-compare list-compare my-lists)
+  
+  (my-check-compare
+   (lambda (x y) (list-compare ci x y))
+   my-lists)
+  
+  (my-check-compare
+   (lambda (x y) (list-compare x y my-empty? my-head my-tail))
+   (map list->my-list my-lists))
+  
+  (my-check-compare
+   (lambda (x y) (list-compare ci x y my-empty? my-head my-tail))
+   (map list->my-list my-lists))
+  
+  ; list-compare-as-vector
+  
+  (my-check-compare list-compare-as-vector my-list-as-vectors)
+  
+  (my-check-compare
+   (lambda (x y) (list-compare-as-vector ci x y))
+   my-list-as-vectors)
+  
+  (my-check-compare
+   (lambda (x y) (list-compare-as-vector x y my-empty? my-head my-tail))
+   (map list->my-list my-list-as-vectors))
+  
+  (my-check-compare
+   (lambda (x y) (list-compare-as-vector ci x y my-empty? my-head my-tail))
+   (map list->my-list my-list-as-vectors))
+  
+  ; vector-compare
+  
+  (my-check-compare vector-compare my-vectors)
+  
+  (my-check-compare
+   (lambda (x y) (vector-compare ci x y))
+   my-vectors)
+  
+  (my-check-compare
+   (lambda (x y) (vector-compare x y my-size my-ref))
+   (map list->my-list my-list-as-vectors))
+  
+  (my-check-compare
+   (lambda (x y) (vector-compare ci x y my-size my-ref))
+   (map list->my-list my-list-as-vectors))
+  
+  ; vector-compare-as-list
+  
+  (my-check-compare vector-compare-as-list my-vector-as-lists)
+  
+  (my-check-compare
+   (lambda (x y) (vector-compare-as-list ci x y))
+   my-vector-as-lists)
+  
+  (my-check-compare
+   (lambda (x y) (vector-compare-as-list x y my-size my-ref))
+   (map list->my-list my-lists))
+  
+  (my-check-compare
+   (lambda (x y) (vector-compare-as-list ci x y my-size my-ref))
+   (map list->my-list my-lists))
+  
+  ) ; check:data-structures
+
+
+(define (check:default-compare)
+  
+  (my-check-compare default-compare my-objects)
+  
+  ; check if default-compare refines pair-compare
+  
+  (my-check-ec
+   (:list x (index ix) my-objects)
+   (:list y (index iy) my-objects)
+   (:let c-coarse (pair-compare x y))
+   (:let c-fine (default-compare x y))
+   (or (eqv? c-coarse 0) (eqv? c-fine c-coarse))
+   (list x y))
+  
+  ; check if default-compare passes on debug-compare
+  
+  (my-check-compare (debug-compare default-compare) my-objects)
+  
+  ) ; check:default-compare
+
+
+(define (sort-by-less xs pred) ; trivial quicksort
+  (if (or (null? xs) (null? (cdr xs)))
+      xs
+      (append 
+       (sort-by-less (list-ec (:list x (cdr xs))
+			      (if (pred x (car xs))) 
+			      x) 
+		     pred)
+       (list (car xs))
+       (sort-by-less (list-ec (:list x (cdr xs))
+			      (if (not (pred x (car xs))))
+			      x) 
+		     pred))))
+
+(define (check:more-examples)
+  
+  ; define recursive order on tree type (nodes are dotted pairs)
+  
+  (my-check-compare
+   (letrec ((c (lambda (x y)
+                 (cond-compare (((null? x) (null? y)) 0)
+                               (else (pair-compare c c x y))))))
+     c)
+   (list '() (list '()) (list '() '()) (list (list '())))
+   ;'(() (() . ()) (() . (() . ())) ((() . ()) . ()))   ; Chicken can't parse this ?
+   )
+  
+  ; redefine default-compare using select-compare
+  
+  (my-check-compare
+   (letrec ((c (lambda (x y)
+                 (select-compare x y
+                                 (null? 0)
+                                 (pair?    (pair-compare    c c x y))
+                                 (boolean? (boolean-compare x y))
+                                 (char?    (char-compare    x y))
+                                 (string?  (string-compare  x y))
+                                 (symbol?  (symbol-compare  x y))
+                                 (number?  (number-compare  x y))
+                                 (vector?  (vector-compare  c x y))
+                                 (else (error "unrecognized type in c" x y))))))
+     c)
+   my-objects)
+  
+  ; redefine default-compare using cond-compare
+  
+  (my-check-compare
+   (letrec ((c (lambda (x y)
+                 (cond-compare
+                  (((null?    x) (null?    y)) 0)
+                  (((pair?    x) (pair?    y)) (pair-compare    c c x y))
+                  (((boolean? x) (boolean? y)) (boolean-compare x y))
+                  (((char?    x) (char?    y)) (char-compare    x y))
+                  (((string?  x) (string?  y)) (string-compare  x y))
+                  (((symbol?  x) (symbol?  y)) (symbol-compare  x y))
+                  (((number?  x) (number?  y)) (number-compare  x y))
+                  (((vector?  x) (vector?  y)) (vector-compare  c x y))
+                  (else (error "unrecognized type in c" x y))))))
+     c)
+   my-objects)
+  
+  ; compare strings with character order reversed
+  
+  (my-check-compare
+   (lambda (x y)
+     (vector-compare-as-list
+      (lambda (x y) (char-compare y x))
+      x y string-length string-ref))
+   '("" "b" "bb" "ba" "a" "ab" "aa"))
+
+  ; examples from SRFI text for <? etc.
+
+  (my-check (>? "laugh" "LOUD") => #t)
+  (my-check (<? string-compare-ci "laugh" "LOUD") => #t)
+  (my-check (sort-by-less '(1 a "b") (<?)) => '("b" a 1))
+  (my-check (sort-by-less '(1 a "b") (>?)) => '(1 a "b"))
+  
+  ) ; check:more-examples
+
+
+; Real life examples
+; ==================
+
+; (update/insert compare x s)
+;    inserts x into list s, or updates an equivalent element by x.
+;      It is assumed that s is sorted with respect to compare,
+;    i.e. (apply chain<=? compare s). The result is a list with x
+;    replacing the first element s[i] for which (=? compare s[i] x),
+;    or with x inserted in the proper place.
+;      The algorithm uses linear insertion from the front.
+
+(define (insert/update compare x s) ; insert x into list s, or update
+  (if (null? s)
+      (list x)
+      (if3 (compare x (car s))
+           (cons x s)
+           (cons x (cdr s))
+           (cons (car s) (insert/update compare x (cdr s))))))
+
+; (index-in-vector compare vec x)
+;    an index i such that (=? compare vec[i] x), or #f if there is none.
+;      It is assumed that s is sorted with respect to compare,
+;    i.e. (apply chain<=? compare (vector->list s)). If there are 
+;    several elements equivalent to x then it is unspecified which
+;    these is chosen.
+;      The algorithm uses binary search.
+
+(define (index-in-vector compare vec x)
+  (let binary-search ((lo -1) (hi (vector-length vec)))
+    ; invariant: vec[lo] < x < vec[hi]
+    (if (=? (- hi lo) 1)
+        #f
+        (let ((mi (quotient (+ lo hi) 2)))
+          (if3 (compare x (vector-ref vec mi))
+               (binary-search lo mi)
+               mi
+               (binary-search mi hi))))))  
+
+
+; Run the checks 
+; ==============
+
+; comment in/out as needed
+(with-test-prefix "atomic" (check:atomic))
+(with-test-prefix "if3" (check:if3))
+(with-test-prefix "ifs" (check:ifs))
+(with-test-prefix "predicates-form-compare"
+  (check:predicates-from-compare))
+(with-test-prefix "pairwise-not=?"
+  (check:pairwise-not=?))
+(with-test-prefix "min/max"
+  (check:min/max))
+(with-test-prefix "kth-largest"
+  (check:kth-largest))
+(with-test-prefix "compare-from-predicates"
+  (check:compare-from-predicates))
+(with-test-prefix "refine-select-cond"
+  (check:refine-select-cond))
+(with-test-prefix "data-structures"
+  (check:data-structures))
+(with-test-prefix "default-compare"
+  (check:default-compare))
+(with-test-prefix "more-examples"
+  (check:more-examples))
+
-- 
tg: (733fded..) t/srfi-67 (depends on: master t/srfi-42)

[-- Attachment #2: Type: text/plain, Size: 63 bytes --]


Regards, Rotty
-- 
Andreas Rottmann -- <http://rotty.yi.org/>

^ permalink raw reply related	[flat|nested] 2+ messages in thread

end of thread, other threads:[~2010-10-03 10:18 UTC | newest]

Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-10-01 22:06 [PATCH] Add implementation of SRFI-67 Andreas Rottmann
2010-10-03 10:18 ` Andy Wingo

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).