diff options
| -rw-r--r-- | mew.scm | 54 | ||||
| -rw-r--r-- | mew.svnwiki | 26 | ||||
| -rw-r--r-- | tests/test.mew | 63 |
3 files changed, 142 insertions, 1 deletions
diff --git a/mew.scm b/mew.scm index 7de52f0..1f25c79 100644 --- a/mew.scm +++ b/mew.scm @@ -2,7 +2,7 @@ (export act accumulate andloc app at boolean - comp cross-product + cmp comp cross-product dec dec! def del-at div dup empty? eof esc fail fin final for for/into fun* @@ -27,6 +27,7 @@ xcond xfold xfold-right xreduce xreduce-right xscan xscan-right -> fun-> fun->> set-> =? <>? + <? <=? >? >=? ~? => =>* and=> fun=> op=> set=> @@ -1295,6 +1296,57 @@ ((char? o) (make-string n o)) (#t (error "no repeat defined")))) + (define (cmp a b) + (cond ((and (real? a) (real? b) (= a b)) 0) + ((and (real? a) (real? b) (< a b)) -1) + ((and (real? a) (real? b) (> a b)) 1) + + ((and (char? a) (char? b) (char=? a b)) 0) + ((and (char? a) (char? b) (char<? a b)) -1) + ((and (char? a) (char? b) (char>? a b)) 1) + + ((and (string? a) (string? b) (string=? a b)) 0) + ((and (string? a) (string? b) (string<? a b)) -1) + ((and (string? a) (string? b) (string>? a b)) 1) + + ((and (null? a) (null? b)) 0) + ((and (list? a) (null? b)) 1) + ((and (null? a) (list? b)) -1) + ((and (list? a) (list? b)) (let ((c (cmp (car a) (car b)))) + (if (zero? c) + (cmp (cdr a) (cdr b)) + c))) + + ((and (vector? a) (vector? b)) (let ((m (min (vector-length a) + (vector-length b)))) + (let loop ((i 0)) + (if (< i m) + (let ((c (cmp (vector-ref a i) + (vector-ref b i)))) + (if (zero? c) + (loop (+ i 1)) + c)) + (cmp (vector-length a) + (vector-length b)))))) + + (else #f))) + + (define (cmp-op f) + (case-lambda + ((a b) (f (cmp a b))) + ((a b . xs) + (let loop ((x a) (xs (cons b xs))) + (if (null? xs) + #t + (if (f (cmp x (car xs))) + (loop (car xs) (cdr xs)) + #f)))))) + + (define <? (cmp-op negative?)) + (define <=? (cmp-op (negate positive?))) + (define >? (cmp-op positive?)) + (define >=? (cmp-op (negate negative?))) + (let ((old-repl-prompt (repl-prompt))) (repl-prompt (lambda () (let ((old-prompt (old-repl-prompt))) diff --git a/mew.svnwiki b/mew.svnwiki index dce8f34..ffb99cb 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -355,6 +355,32 @@ set of keys and {{equal?}} values. Return true if all values are pairwise different. +== Generic comparison + +<procedure>(cmp <a> <b>)</procedure> + +Compare the real/char/string/list/vector {{<a>}} to {{<b>}} and +return -1 if {{<a>}} is less than {{<b>}}, +0 if {{<a>}} is equal to {{<b>}} +1 if {{<a>}} is greater than {{<b>}}. +Return false if {{<a>}} and {{<b>}} cannot be compared. + +Lists and vectors are compared in lexicographic order using {{cmp}} +recursively. + +<procedure>(<? <a> <b> ...)</procedure> +<procedure>(>? <a> <b> ...)</procedure> +<procedure>(<=? <a> <b> ...)</procedure> +<procedure>(>=? <a> <b> ...)</procedure> + +Return true if all arguments are monotonically increasing, +monotonically decreasing, monotonically non-decreasing, or +monotonically non-increasing according to {{cmp}}, and false +otherwise. + +It is an error to compare uncomparable values. + + == Data types <procedure>(get <obj> <idx>)</procedure> diff --git a/tests/test.mew b/tests/test.mew index 96f0764..246f9e7 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -729,3 +729,66 @@ (test #() (repeat #(1 2 3) 0)) (test "" (repeat "123" 0)) (test "" (repeat #\x 0))) + +(test-group "cmp" + (test -1 (cmp 4 5)) + (test -1 (cmp -4 5)) + (test -1 (cmp -5 -4)) + (test -1 (cmp 4 5.5)) + (test 0 (cmp 4 4.0)) + (test 0 (cmp -0.0 0.0)) + (test 1 (cmp 1/4 1/5)) + (test 1 (cmp 5 4)) + + (test -1 (cmp "bar" "foo")) + (test 1 (cmp "foo" "bar")) + (test 0 (cmp "foo" "foo")) + (test -1 (cmp "foo" "foox")) + (test -1 (cmp "fo" "foo")) + + (test -1 (cmp #\a #\z)) + (test 0 (cmp #\a #\a)) + (test 1 (cmp #\z #\a)) + + (test -1 (cmp '(1 2 3) '(1 2 4))) + (test 0 (cmp '(1 2 3) '(1 2 3))) + (test 1 (cmp '(1 2 5) '(1 2 3))) + (test 1 (cmp '(1 2 3) '(1 2))) + + (test -1 (cmp #(1 2 3) #(1 2 4))) + (test 0 (cmp #(1 2 3) #(1 2 3))) + (test 1 (cmp #(1 2 5) #(1 2 3))) + (test 1 (cmp #(1 2 3) #(1 2))) + + (test #f (cmp 42 "foo"))) + +(test-group "<?" + (test #t (<? 1 2 3)) + (test #f (<? 3 2 1)) + (test #f (<? 1 1 2)) + + (test-error (<?)) + (test-error (<? 1)) + + (test-error (<? "foo" 2 #(6 7 8)))) + +(test-group "<=?" + (test #t (<=? 1 2 3)) + (test #f (<=? 3 2 1)) + (test #t (<=? 1 1 2)) + + (test-error (<=? "foo" 2 #(6 7 8)))) + +(test-group ">?" + (test #f (>? 1 2 3)) + (test #t (>? 3 2 1)) + (test #f (>? 1 1 2)) + + (test-error (>? "foo" 2 #(6 7 8)))) + +(test-group ">=?" + (test #f (>=? 1 2 3)) + (test #t (>=? 3 2 1)) + (test #t (>=? 2 1 1)) + + (test-error (>=? "foo" 2 #(6 7 8)))) |