[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-131-ge
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-131-geb0b45f |
|
Date: |
Sun, 03 Oct 2010 10:15:00 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=eb0b45facc3cdaf459f75b207f74d29366f51400
The branch, master has been updated
via eb0b45facc3cdaf459f75b207f74d29366f51400 (commit)
via 8175a07e34605cf3e716eab380b195cf8f3b5f2b (commit)
from fdc8fd46fd02d072b6b5f183178862650fe36305 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit eb0b45facc3cdaf459f75b207f74d29366f51400
Author: Andy Wingo <address@hidden>
Date: Sun Oct 3 12:18:14 2010 +0200
srfi-67 #:replace work
* module/srfi/srfi-67.scm (string-compare, string-compare-ci): #:replace
these bindings.
commit 8175a07e34605cf3e716eab380b195cf8f3b5f2b
Author: Andreas Rottmann <address@hidden>
Date: Sun Oct 3 12:14:21 2010 +0200
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.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/srfi-modules.texi | 7 +
module/Makefile.am | 2 +
module/srfi/srfi-67.scm | 86 +++
module/srfi/srfi-67/compare.scm | 707 ++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-67.test | 1221 +++++++++++++++++++++++++++++++++++++++
6 files changed, 2024 insertions(+), 0 deletions(-)
create mode 100644 module/srfi/srfi-67.scm
create mode 100644 module/srfi/srfi-67/compare.scm
create mode 100644 test-suite/tests/srfi-67.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 780f10d..2ca971e 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.
@@ -4056,6 +4057,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}.
address@hidden SRFI-67
address@hidden SRFI-67 - Compare procedures
address@hidden 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..7a43ee5
--- /dev/null
+++ b/module/srfi/srfi-67.scm
@@ -0,0 +1,86 @@
+;;; 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
+ symbol-compare
+ vector-compare
+ vector-compare-as-list)
+ #:replace (string-compare string-compare-ci)
+ #: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)
+; address@hidden, address@hidden
+; 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))
+
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-12-131-geb0b45f,
Andy Wingo <=