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