Macro for generating kahan-babushka-klein folds.

macro.clj

;; general impl of https://en.wikipedia.org/wiki/Kahan_summation_algorithm#Further_enhancements

(defn- klein-term [acc delta]
  `[sum# (+ ~acc ~delta)
    ~delta (if (>= (Math/abs ~(with-meta acc {:tag 'double}))
                   (Math/abs ~(with-meta delta {:tag 'double})))
             (+ (- ~acc sum#) ~delta)
             (+ (- ~delta sum#) ~acc))
    ~acc sum#])

(defn- kbk-foldn-body
  "Split out from the macro so we can use it to build SCI macros."
  [n]
  (let [syms   (into [] (repeatedly (inc n) gensym))
        prefix (pop syms)
        final  (peek syms)
        delta  (gensym)]
    `[([] [~@(repeat (inc n) 0.0)])
      ([accs#] (reduce + accs#))
      ([~syms ~delta]
       (let [~@(mapcat #(klein-term % delta) prefix)]
         [~@prefix (+ ~final ~delta)]))]))

(defmacro kbk-foldn [n]
  `(fn ~@(kbk-foldn-body n)))

(defn sum
  ([xs]
   (*fold*
    (reduce *fold* (*fold*) xs)))
  ([f low high]
   (let [xs (range low high)]
     (transduce (map f) *fold* xs))))

(defn naive-fold
  ([] 0.0)
  ([x] x)
  ([acc x]
   (+ acc x)))

(def ^:dynamic *fold* naive-fold)

;; calling the macro with `0` gives the naive fold:
(binding [*fold* naive-fold]
  (sum #(/ 1.0 (inc %)) 0 50000000))
;; 18.304749238293297

(binding [*fold* (kbk-foldn 0)]
  (sum #(/ 1.0 (inc %)) 0 50000000))
;; 18.304749238293297

;; Identical to KahanBabushkaNeumaierSum:
(binding [*fold* (kbk-foldn 1)]
  (sum #(/ 1.0 (inc %)) 0 50000000))
;; 18.304749238293955

;; Identical to KahanBabushkaKleinSum:
(binding [*fold* (kbk-foldn 2)]
  (sum #(/ 1.0 (inc %)) 0 50000000))
;; 18.304749238293955