add generic comparison

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))))