708 lines
24 KiB
Scheme
708 lines
24 KiB
Scheme
; 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))))
|