add generic comparison

1 files changed, 53 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)))