From d77249734563e95283105fe233731ee6d277b655 Mon Sep 17 00:00:00 2001
From: Hubert Iwaniuk <hubert@happyhacking.nl>
Date: Tue, 15 May 2012 18:21:43 +0200
Subject: [PATCH] Introduce IComparable.

Along with initial implementation of compare for:
- PersistentVector

And some tests.
---
 src/cljs/cljs/core.cljs       |   39 ++++++++++++++++++++++++++++++++-----
 test/cljs/cljs/core_test.cljs |   42 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 75 insertions(+), 6 deletions(-)

diff --git a/src/cljs/cljs/core.cljs b/src/cljs/cljs/core.cljs
index 54c9bef..5c20bbb 100644
--- a/src/cljs/cljs/core.cljs
+++ b/src/cljs/cljs/core.cljs
@@ -260,6 +260,9 @@
 (defprotocol ITransientSet
   (-disjoin! [tcoll v]))
 
+(defprotocol IComparable
+  (-compare [x y]))
+
 ;;;;;;;;;;;;;;;;;;; fundamentals ;;;;;;;;;;;;;;;
 (defn ^boolean identical?
   "Tests if 2 arguments are the same object"
@@ -913,14 +916,32 @@ reduces them without incurring seq initialization"
 (defn compare
   "Comparator. Returns a negative number, zero, or a positive number
   when x is logically 'less than', 'equal to', or 'greater than'
-  y. Uses google.array.defaultCompare for objects of the same type
-  and special-cases nil to be less than any other object."
+  y. Uses IComparable if available and google.array.defaultCompare for objects
+ of the same type and special-cases nil to be less than any other object."
   [x y]
   (cond
-    (identical? (type x) (type y)) (garray/defaultCompare x y)
-    (nil? x) -1
-    (nil? y) 1
-    :else (throw (js/Error. "compare on non-nil objects of different types"))))
+   (identical? x y) 0
+   (nil? x) -1
+   (nil? y) 1
+   (identical? (type x) (type y)) (if (satisfies? IComparable x)
+                                    (-compare x y)
+                                    (garray/defaultCompare x y))
+   :else (throw (js/Error. "compare on non-nil objects of different types"))))
+
+(defn ^:private compare-indexed
+  "Compare indexed collection."
+  ([xs ys]
+     (let [xl (count xs)
+           yl (count ys)]
+       (cond
+        (< xl yl) -1
+        (> xl yl) 1
+        :else (compare-indexed xs ys xl 0))))
+  ([xs ys len n]
+     (let [d (compare (nth xs n) (nth ys n))]
+       (if (and (zero? d) (< (+ n 1) len))
+         (recur xs ys len (inc n))
+         d))))
 
 (defn ^:private fn->comparator
   "Given a fn that might be boolean valued or a comparator,
@@ -5864,6 +5885,12 @@ reduces them without incurring seq initialization"
   Range
   (-pr-seq [coll opts] (pr-sequential pr-seq "(" " " ")" opts coll)))
 
+
+;; IComparable
+(extend-protocol IComparable
+  PersistentVector
+  (-compare [x y] (compare-indexed x y)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Reference Types ;;;;;;;;;;;;;;;;
 
 (deftype Atom [state meta validator watches]
diff --git a/test/cljs/cljs/core_test.cljs b/test/cljs/cljs/core_test.cljs
index 4183318..0f46da3 100644
--- a/test/cljs/cljs/core_test.cljs
+++ b/test/cljs/cljs/core_test.cljs
@@ -1410,5 +1410,47 @@
                  :fail)
                :ok)))
 
+  ;; IComparable
+  (assert (=  0 (compare false false)))
+  (assert (= -1 (compare false true)))
+  (assert (=  1 (compare true  false)))
+
+  (assert (= -1 (compare  0  1)))
+  (assert (= -1 (compare -1  1)))
+  (assert (=  0 (compare  1  1)))
+  (assert (=  1 (compare  1  0)))
+  (assert (=  1 (compare  1 -1)))
+
+  (assert (=  0 (compare "cljs" "cljs")))
+  (assert (=  0 (compare :cljs :cljs)))
+  (assert (=  0 (compare 'cljs 'cljs)))
+  (assert (= -1 (compare "a" "b")))
+  (assert (= -1 (compare :a :b)))
+  (assert (= -1 (compare 'a 'b)))
+  ;; cases involving ns
+  (assert (= -1 (compare :b/a :c/a)))
+  #_(assert (= -1 (compare :c :a/b)))
+  #_(assert (=  1 (compare :a/b :c)))
+  (assert (= -1 (compare 'b/a 'c/a)))
+  #_(assert (= -1 (compare 'c 'a/b)))
+  #_(assert (=  1 (compare 'a/b 'c)))
+
+  ;; This is different from clj. clj gives -2 next 3 tests
+  (assert (= -1 (compare "a" "c")))
+  (assert (= -1 (compare :a :c)))
+  (assert (= -1 (compare 'a 'c)))
+
+  (assert (= -1 (compare [1 2] [1 1 1])))
+  (assert (= -1 (compare [1 2] [1 2 1])))
+  (assert (= -1 (compare [1 1] [1 2])))
+  (assert (=  0 (compare [1 2] [1 2])))
+  (assert (=  1 (compare [1 2] [1 1])))
+  (assert (=  1 (compare [1 1 1] [1 2])))
+  (assert (=  1 (compare [1 1 2] [1 1 1])))
+
+  (assert (= -1 (compare (subvec [1 2 3] 1) (subvec [1 2 4] 1))))
+  (assert (=  0 (compare (subvec [1 2 3] 1) (subvec [1 2 3] 1))))
+  (assert (=  1 (compare (subvec [1 2 4] 1) (subvec [1 2 3] 1))))
+
   :ok
   )
-- 
1.7.8.4