transducers with wrap

gistfile1.clj

(defprotocol IReducing
  "A value protocol for augmented reducing functions."
  (-init
    "Returns default initial unwrapped value."
    [this])
  (-finish
    "Returns final wrapped result, and performs flushing or cleaning
     of internal state. Returned wrap should have cleaned state,
     so that eventual subsequent calls to -finish will perform
     correctly.
     Input may be reduced, which signals that
     finalization of early terminated reduction should be performed.
     Implementation must return reduced object at when `wrap` is reduced."
    [this wrap])
  (-wrap
    "Returns wrapped result `ret`. Initializes reducing state."
    [this ret])
  (-unwrap
    "Returns unwrapped result `ret`."
    [this wrap])
  (-step
    "Returns new wrapped result based on applying given input values
     to the `wrap`."
    [this wrap, val]
    [this wrap, val, val2]
    [this wrap, val, val2, val3]
    [this wrap, val, val2, val3, val4]
    [this wrap, val, val2, val3, val4, more]))

(defn ^:private unwrap-advance
  [r wrap]
  (if (reduced? wrap) 
    (reduced (-unwrap r @wrap))
    (-unwrap r wrap)))

(defn ^:private reducing-function
  "Returns a reducing function created from augmented reducing
   function `r`."
  [r]
  (fn
    ([wrap val] (-step r wrap val))
    ([wrap val val2] (-step r wrap val val2))
    ([wrap val val2 val3] (-step r wrap val val2 val3))
    ([wrap val val2 val3 val4]
       (-step r wrap val val2 val3 val4))
    ([wrap val val2 val3 val4 & more]
       (-step r wrap val val2 val3 val4 more))))

(defn ^:private reduce-augmented*
  "Returns a result of the reduction of `coll` with `reduce-fn`
   function taking [coll reducef init] in that order, and with the
   augmented reducing function `r` and with initial value `init`,
   which defaults to (-init r). May return reduced object."
  ([coll, reduce-fn, r]
     (reduce-augmented* coll reduce-fn r (-init r)))
  ([coll, reduce-fn, r, init]
     (->> (reduce-fn coll (reducing-function r) (-wrap r init))
          (-finish r)
          (unwrap-advance r))))

(defn strip-reduced
  "Returns a referenced object if `x` is reduced, otherwise returns
   `x`."
  [x]
  (if (reduced? x) @x x))

(defn ^:private reduce*
  [coll, reducef, init]
  (if (nil? coll) init (reduce reducef init coll)))

(defn reduce-augmented
  "Returns a result of the reduction of `coll` with the augmented
   reducing function `r` and with initial value `init`, which
   defaults to (-init r)."
  ([r, coll]
     (strip-reduced (reduce-augmented* coll reduce* r (-init r))))
  ([r, init, coll]
     (strip-reduced (reduce-augmented* coll reduce* r init))))

(deftype BareReducing
  "An augmented reducing type which uses `reducef` for reducing
   steps and for an initial value."
  [reducef]
  IReducing
  (-init [this] (reducef))
  (-finish [this wrap] wrap)
  (-wrap [this ret] ret)
  (-unwrap [this wrap] wrap)
  (-step [this wrap val] (reducef wrap val))
  (-step [this wrap val val2] (reducef wrap val val2))
  (-step [this wrap val val2 val3] (reducef wrap val val2 val3))
  (-step [this wrap val val2 val3 val4]
    (reducef wrap val val2 val3 val4))
  (-step [this wrap val val2 val3 val4 more]
    (apply reducef wrap val val2 val3 val4 more)))

(deftype Reducing
  "An augmented reducing type which uses `reducef` for reducing
   steps and `init` for an initial value."
  [reducef, init]
  IReducing
  (-init [this] init)
  (-finish [this wrap] wrap)
  (-wrap [this ret] ret)
  (-unwrap [this wrap] wrap)
  (-step [this wrap val] (reducef wrap val))
  (-step [this wrap val val2] (reducef wrap val val2))
  (-step [this wrap val val2 val3] (reducef wrap val val2 val3))
  (-step [this wrap val val2 val3 val4]
    (reducef wrap val val2 val3 val4))
  (-step [this wrap val val2 val3 val4 more]
    (apply reducef wrap val val2 val3 val4 more)))

(defn reducing
  "Returns an augmented reducing function which uses `reducef` for
   reducing steps and `init` for an initial value, without fold
   support. Uses (reducef) as an initial value if `init` is not
   supplied."
  ([reducef]
     (->BareReducing reducef))
  ([reducef, init]
     (->Reducing reducef init)))

(defn transduce
  "Returns a result of the reduction of `coll` with reducing function `reducef`
   and initial value `init`, which defaults to (reducef) if not provided,
   and transducer `xform`."
  ([xform, reducef, coll]
     (reduce-augmented (xform (reducing reducef)) coll))
  ([xform, reducef, init, coll]
     (reduce-augmented (xform (reducing reducef init)) coll)))

;; take

(deftype IntWrap [i ret])

(defn ^:private int-advance
  [ret i]
  (if (reduced? ret) 
    (reduced (->IntWrap i @ret))
    (->IntWrap i ret))

(defn ^:private reduced-int-advance
  [ret i]
  (if (reduced? ret) 
    (reduced (->IntWrap i @ret))
    (reduced (->IntWrap i ret))))

(deftype TakeReducing
  "Reducing type for take."
  [r n]
  IReducing
  (-init [this] (-init r))
  (-finish [this wrap]
    (->> (if (reduced? wrap)
          (reduced (.-ret ^IntWrap @wrap))
          (.-ret ^IntWrap wrap))
        (-finish r)
        (->IntWrap nil)))
  (-wrap [this ret] (->IntWrap (dec n) (-wrap r ret)))
  (-unwrap [this wrap]
    (-unwrap r (.-ret ^IntWrap wrap)))
  (-step [this wrap val]
    (let [ret (.-ret ^IntWrap wrap)
          i (.-i ^IntWrap wrap)]
      (if (zero? i)
        (reduced-int-advance (-step r ret val) i)
        (int-advance (-step r ret val) (dec i))))))

(defn take
  "A transducer that passes at most `n` step values."
  ([n]
    (fn [r] (->TakeReducing r n)))
  ([n coll]
    ;; ... elided
  )