mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
b3da54d181
- "filesystem" -> "file system" - remove doubled words - use EXIT_* macros instead of literal numbers - update `syntax-check' exclusion files
1221 lines
40 KiB
Scheme
1221 lines
40 KiB
Scheme
;;; -*- 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 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))
|
|
|