InternalReduce

;; Copyright 2010 Relevance, Inc. Same license as Clojure http://clojure.org. You know the drill.
(ns clojure.core.protocols
  (:refer-clojure :exclude [reduce nth count]))

#_(def array-classes
  (map
   #(Class/forName %)
   ["[Ljava.lang.Object;"
    "[B" "[F" "[I" "[D" "[Z" "[J" "[C"]))

(defprotocol InternalReduce
  (internal-reduce [coll f start]))

(extend-protocol InternalReduce
  nil
  (internal-reduce
   [s f val]
   val)

  clojure.lang.PersistentVector$ChunkedSeq
  (internal-reduce
   [s f val]
   (if-let [s (seq s)]
     (recur (chunk-next s)
            f
            (.reduce (chunk-first s) f val))
     val))
  
  ;; if supers knew partial ordering, could ChunkedSeq and ChunkedCons
  ;; be combined under clojure.lang.IChunkedSeq?
  clojure.lang.ChunkedCons
  (internal-reduce
   [s f val]
   (if-let [s (seq s)]
     (recur (chunk-next s)
            f
            (.reduce (chunk-first s) f val))
     val))
  
  ;; repeat for other array types
  clojure.lang.ArraySeq$ArraySeq_int
  (internal-reduce
   [a-seq f val]
   (let [arr (.array a-seq)]
     (loop [i (.index a-seq)
            val val]
       (if (< i (alength arr))
         (recur (inc i) (f val (aget arr i)))
         val))))
  
  clojure.lang.StringSeq
  (internal-reduce
   [str-seq f val]
   (let [s (.s str-seq)]
     (loop [i (.i str-seq)
            val val]
       (if (< i (.length s))
         (recur (inc i) (f val (.charAt s i)))
         val))))

  ;; are there pathological cases that return a diff class on each next?
  java.lang.Object
  (internal-reduce
   [s f val]
   (let [orig (seq s)]
     (if orig
       (loop [s orig
              f f
              val val]
         (if (= (class s) (class orig)) ;; fall out if we might do better
           (recur (next s) f (f val (first s)))
           (internal-reduce s f val)
           ))
       val))))

(defn reduce
  ([f coll]
     (if-let [s (seq coll)]
       (reduce f (first s) (next s))
       (f)))
  ([f start coll]
     (let [s (seq coll)]
       (internal-reduce s f start))))