1 files changed, 177 insertions, 0 deletions
diff --git a/src/main/clojure/clojure/contrib/generic/comparison.clj b/src/main/clojure/clojure/contrib/generic/comparison.clj
new file mode 100644
index 00000000..7e2b81fd
--- /dev/null
+++ b/src/main/clojure/clojure/contrib/generic/comparison.clj
@@ -0,0 +1,177 @@
+;; Generic interfaces for comparison operations
+
+;; by Konrad Hinsen
+;; last updated May 5, 2009
+
+;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
+;; and distribution terms for this software are covered by the Eclipse
+;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns
+  #^{:author "Konrad Hinsen"
+     :doc "Generic comparison interface
+           This library defines generic versions of = < > <= >= zero?
+           as multimethods that can be defined for any type. Of the
+           greater/less-than relations, types must minimally implement >."}
+  clojure.contrib.generic.comparison
+  (:refer-clojure :exclude [= < > <= >= zero?])
+  (:use [clojure.contrib.generic
+	 :only (root-type nulary-type nary-type nary-dispatch)]))
+
+;
+; zero?
+;
+(defmulti zero?
+  "Return true of x is zero."
+  {:arglists '([x])}
+  type)
+
+;
+; Equality
+;
+(defmulti =
+  "Return true if all arguments are equal. The minimal implementation for type
+   ::my-type is the binary form with dispatch value [::my-type ::my-type]."
+  {:arglists '([x] [x y] [x y & more])}
+  nary-dispatch)
+
+(defmethod = root-type
+  [x] true)
+
+(defmethod = nary-type
+  [x y & more]
+  (if (= x y)
+    (if (next more)
+      (recur y (first more) (next more))
+      (= y (first more)))
+    false))
+
+;
+; Greater-than
+;
+(defmulti >
+  "Return true if each argument is larger than the following ones.
+   The minimal implementation for type ::my-type is the binary form
+   with dispatch value [::my-type ::my-type]."
+  {:arglists '([x] [x y] [x y & more])}
+  nary-dispatch)
+
+(defmethod > root-type
+  [x] true)
+
+(defmethod > nary-type
+  [x y & more]
+  (if (> x y)
+    (if (next more)
+      (recur y (first more) (next more))
+      (> y (first more)))
+    false))
+
+;
+; Less-than defaults to greater-than with arguments inversed
+;
+(defmulti <
+  "Return true if each argument is smaller than the following ones.
+   The minimal implementation for type ::my-type is the binary form
+   with dispatch value [::my-type ::my-type]. A default implementation
+   is provided in terms of >."
+  {:arglists '([x] [x y] [x y & more])}
+  nary-dispatch)
+
+(defmethod < root-type
+  [x] true)
+
+(defmethod < [root-type root-type]
+  [x y]
+  (> y x))
+
+(defmethod < nary-type
+  [x y & more]
+  (if (< x y)
+    (if (next more)
+      (recur y (first more) (next more))
+      (< y (first more)))
+    false))
+
+;
+; Greater-or-equal defaults to (complement <)
+;
+(defmulti >=
+  "Return true if each argument is larger than or equal to the following
+   ones. The minimal implementation for type ::my-type is the binary form
+   with dispatch value [::my-type ::my-type]. A default implementation
+   is provided in terms of <."
+  {:arglists '([x] [x y] [x y & more])}
+  nary-dispatch)
+
+(defmethod >= root-type
+  [x] true)
+
+(defmethod >= [root-type root-type]
+  [x y]
+  (not (< x y)))
+
+(defmethod >= nary-type
+  [x y & more]
+  (if (>= x y)
+    (if (next more)
+      (recur y (first more) (next more))
+      (>= y (first more)))
+    false))
+
+;
+; Less-than defaults to (complement >)
+;
+(defmulti <=
+  "Return true if each arguments is smaller than or equal to the following
+   ones. The minimal implementation for type ::my-type is the binary form
+   with dispatch value [::my-type ::my-type]. A default implementation
+   is provided in terms of >."
+  {:arglists '([x] [x y] [x y & more])}
+  nary-dispatch)
+
+(defmethod <= root-type
+  [x] true)
+
+(defmethod >= [root-type root-type]
+  [x y]
+  (not (> x y)))
+
+(defmethod <= nary-type
+  [x y & more]
+  (if (<= x y)
+    (if (next more)
+      (recur y (first more) (next more))
+      (<= y (first more)))
+    false))
+
+;
+; Implementations for Clojure's built-in types
+;
+(defmethod zero? java.lang.Number
+  [x]
+  (clojure.core/zero? x))
+
+(defmethod = [Object Object]
+  [x y]
+  (clojure.core/= x y))
+
+(defmethod > [Object Object]
+  [x y]
+  (clojure.core/> x y))
+
+(defmethod < [Object Object]
+  [x y]
+  (clojure.core/< x y))
+
+(defmethod >= [Object Object]
+  [x y]
+  (clojure.core/>= x y))
+
+(defmethod <= [Object Object]
+  [x y]
+  (clojure.core/<= x y))