From: Andreas Rottmann 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 +;; . + +;;; Commentary: + +;; This module is not yet documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-67) + #:export (/>=? + >/>? + >=/>=? + >=/>? + >=? + >? + boolean-compare + 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>? + 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-; pairwise-not=? +; SE, 16-Feb-2005: case-compare -> if-compare -> if3; kth-largest modified; if 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? + (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? 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>=?) + + +; 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>=?) + + +; 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=? charstring 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 * ) +; runs (every?-ec * ), counting the times +; is evaluated as a correct example, and stopping at the first +; counter example for which 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 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-not=? (lambda (x y) (not (= x y)))) + + ) ; check:if2 + +; (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 not=? (lambda (x y) (not (= x y)))) + + (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>=? >=) + + ) ; 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 ? "laugh" "LOUD") => #t) + (my-check ( #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)