From 46e5645f223b680d07f0381a7002989ebde16fb4 Mon Sep 17 00:00:00 2001
From: Chongkai Zhu <chongkai@racket-lang.org>
Date: Sat, 19 Nov 2005 07:29:50 +0000
Subject: [PATCH] SRFI 67 Compare Procedures

svn: r1351
---
 collects/srfi/67.ss                    |   3 +
 collects/srfi/67/compare-reference.scm | 707 +++++++++++++++++++++++++
 collects/srfi/67/compare.ss            |  70 +++
 collects/srfi/doc.txt                  |   1 +
 4 files changed, 781 insertions(+)
 create mode 100644 collects/srfi/67.ss
 create mode 100644 collects/srfi/67/compare-reference.scm
 create mode 100644 collects/srfi/67/compare.ss

diff --git a/collects/srfi/67.ss b/collects/srfi/67.ss
new file mode 100644
index 0000000000..51966719c6
--- /dev/null
+++ b/collects/srfi/67.ss
@@ -0,0 +1,3 @@
+(module |67| mzscheme
+  (require (lib "compare.ss" "srfi" "67"))
+  (provide (all-from (lib "compare.ss" "srfi" "67"))))
\ No newline at end of file
diff --git a/collects/srfi/67/compare-reference.scm b/collects/srfi/67/compare-reference.scm
new file mode 100644
index 0000000000..21b0e94c4d
--- /dev/null
+++ b/collects/srfi/67/compare-reference.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/collects/srfi/67/compare.ss b/collects/srfi/67/compare.ss
new file mode 100644
index 0000000000..d2b2dc4c9a
--- /dev/null
+++ b/collects/srfi/67/compare.ss
@@ -0,0 +1,70 @@
+(module compare mzscheme
+  (require (lib "include.ss")
+           (lib "27.ss" "srfi"))
+  
+  (include "compare-reference.scm")
+  
+  (define current-compare (make-parameter default-compare))
+  (provide current-compare)
+  
+  (provide </<=? </<? <=/<=? <=/<? <=? <?
+           =?
+           >/>=? >/>? >=/>=? >=/>? >=? >?
+           
+           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))
diff --git a/collects/srfi/doc.txt b/collects/srfi/doc.txt
index 1aaebd1673..1da7d5fe86 100644
--- a/collects/srfi/doc.txt
+++ b/collects/srfi/doc.txt
@@ -107,6 +107,7 @@ number of the already ported SRFIs:
  SRFI-57            records.ss                    57
  SRFI-59            vicinity.ss                   59
  SRFI-60            60.ss                         60
+ SRFI-67            compare.ss                    67
  SRFI-69            hash.ss                       69
 
 Notes: