R-reduce is an abstraction of folding operations from right to left

example-to-use-r-reduce.clj

(import 'java.util.Date java.text.SimpleDateFormat)

(defn r-reduce [f coll retn pred]
    (loop [[c & cs :as curr] coll rvsd '()]
      (if (or (nil? c) (pred curr))
          (loop [acc (retn curr) [r & rs] rvsd]
            (if r (recur (f r acc) rs) acc))
          (recur cs (cons c rvsd)))))

(def sdf (SimpleDateFormat. "yyyy-MM-dd"))
(defn s2t [s] (.getTime (.parse sdf s)))
(defn t2s [t] (.format sdf (Date. t)))

(def mails
  (sorted-map
    (s2t "2011-01-01") {:subject "s1" :from "Alice"   :body "m1"}
    (s2t "2011-03-01") {:subject "s2" :from "Bob"     :body "m2"}
    (s2t "2011-05-01") {:subject "s3" :from "Charlie" :body "m3"}
    (s2t "2011-07-01") {:subject "s4" :from "Alice"   :body "m4"}
    (s2t "2011-09-01") {:subject "s5" :from "Bob"     :body "m5"}
    (s2t "2011-11-01") {:subject "s6" :from "Chalie"  :body "m6"}
    (s2t "2012-01-01") {:subject "s7" :from "Alice"   :body "m7"}
    (s2t "2012-03-01") {:subject "s8" :from "Bob"     :body "m8"}
    (s2t "2012-05-01") {:subject "s9" :from "Charlie" :body "m9"}))

; Collect mails from "Alice" in mails coming before "2012-01-01"
(pprint
  (loop [[[t b :as c] & r] (apply list mails) acc '()]
    (if (or (nil? c) (<= (s2t "2012-01-01") t))
        (reverse acc)
        (recur r
               (if (= (b :from) "Alice")
                   (cons (assoc b :date (t2s t)) acc)
                   acc)))))
; ->
; ({:subject "s1", :from "Alice", :date "2011-01-01", :body "m1"}
;  {:subject "s4", :from "Alice", :date "2011-07-01", :body "m4"})

; with r-reduce
(pprint
  (r-reduce
    (fn [[t b] acc]
      (if (= (b :from) "Alice")
          (cons (assoc b :date (t2s t)) acc)
          acc))
    (apply list mails)
    (fn [x] '())
    (fn [[[t _] & _]] (<= (s2t "2012-01-01") t))))

; ->
; ({:subject "s1", :from "Alice", :date "2011-01-01", :body "m1"}
;  {:subject "s4", :from "Alice", :date "2011-07-01", :body "m4"})

;; For the current example, 'filter' suffices the purpose.
;; An example 'filter' doesn't suffice is a case that I want to decide if a loop should stop
;; or not by the accumulated state.
;; So 'pred' should be applied not to the current coll in the loop but the current accumulated
;; result of calculations.
;; Doesn't it suffice to collect reversed operands?

r-reduce.clj

; 'R-reduce' is an abstraction of folding operations from right to left.
; Using this 'r-reduce', you can write 'take', 'drop', 'take-while',
; 'drop-while', 'reverse', 'fold-right' and 'reduce-right' without writing
; loops explicitly.
;
; 'Fold-right' and 'reduce-right' themselves are separately defined in
; reduce-right.clj of this gist using the same semantics as this 'r-reduce'
; but not using this 'r-reduce' for efficiency.
; 'Take', 'drop', 'take-while', 'drop-while' and 'reverse' have already
; defined in clojure.core.
; So in this file, the prefix 'my-' is added to variants of them defined
; in order to test if this 'r-reduce' can implement these functionalities.

(use 'clojure.test)

(defn r-reduce
 "An abstraction for functions having structures like fold-right.
  'coll' is a collection. 'f' is a function accepts two arugments.
  'pred' is a function which returns if a condition is to be stopped or not.
  'init' is an initial value for states and 'updt' is a function to update a
  state.

  Supposed
    stat == (s1 s2 ... sk-1 sk ... sn)
         == (init (updt init) (updt (updt init)) ... )
  and given
    coll == (x1 x2 ... xk-1 xk ... xn)
  , 'r-reduce' returns
    (f x1 (f x2 ... (f xk-1 (retn sk)) ... ))
  where '(pred si)' returns true first at i == k.

  If 'init' and 'updt' aren't specified,
  'coll' and 'next' are used respectively as their defaults.
  In this case, 'r-reduce' returns
    (f x1 (f x2 ... (f xk-1 (retn (xk xk+1 ... xn))) ... ))
  where '(pred (xi xi+1 ... xn))' returns true first at i == k.

  Besides 'init' and 'updt', 'pred' isn't specified,
  '#(nil? (first %))' is used as its defaults.
  In this case 'r-reduce' returns
    (f x1 (f x2 ... (f xn (retn '())) ... ))
  ."
  ([f coll retn]
    (loop [[c & cs :as curr] coll rvsd '()]
      (if (nil? c)
          (loop [acc (retn curr) [r & rs] rvsd]
            (if r (recur (f r acc) rs) acc))
          (recur cs (cons c rvsd)))))
  ([f coll retn pred]
    (loop [[c & cs :as curr] coll rvsd '()]
      (if (or (nil? c) (pred curr))
          (loop [acc (retn curr) [r & rs] rvsd]
            (if r (recur (f r acc) rs) acc))
          (recur cs (cons c rvsd)))))
  ([f coll retn init updt pred]
    (loop [[c & cs :as curr] coll rvsd '() stat init]
      (if (or (nil? c) (pred stat))
          (loop [acc (retn curr) [r & rs] rvsd]
            (if r (recur (f r acc) rs) acc))
          (recur cs (cons c rvsd) (updt stat))))))

(defn my-fold-right [f z coll]
  (r-reduce f coll (fn [x] z)))

(defn my-reduce-right [f coll]
  (r-reduce f coll first #(nil? (next %))))

(defn my-take [n coll]
  (r-reduce cons coll (fn [x] '()) 0 inc #(<= n %)))

(defn my-drop [n coll]
  (r-reduce (fn [x y] y) coll identity 0 inc #(<= n %)))

(defn my-take-while [p coll]
  (r-reduce cons coll (fn [x] '()) #(not (p (first %)))))

(defn my-drop-while [p coll]
  (r-reduce (fn [x y] y) coll identity #(not (p (first %)))))

(defn my-reverse [coll]
  (r-reduce #(concat %2 (list %)) coll (fn [x] '())))

(deftest test-reduce-rights
  (are [result expected] (= result expected)
    (my-fold-right - 2 '(3 1 4 1 5 9))    3
    (my-reduce-right - '(3 1 4 1 5 9 2))  3
    (my-take 5 '(3 1 4 1 5 9 2))          '(3 1 4 1 5)
    (my-drop 5 '(3 1 4 1 5 9 2))          '(9 2)
    (my-take-while odd? '(3 1 4 1 5 9 2)) '(3 1)
    (my-drop-while odd? '(3 1 4 1 5 9 2)) '(4 1 5 9 2)
    (my-reverse '(3 1 4 1 5 9 2))         '(2 9 5 1 4 1 3)))

r-reduce.lisp

; This is an answer of my question in reduce-right.lisp
; Using this 'r-reduce', you can write 'take', 'drop', 'take-while' and 'drop-while'
; without writing loops explicitly.

(defun r-reduce (init updt pred retn f ls)
  (labels
    ((rec (stat curr cont)
       (if (or (funcall pred stat) (null (cdr curr)))
           (funcall cont (funcall retn curr))
           (rec (funcall updt stat)
                (cdr curr)
                #'(lambda (x)
                    (funcall cont
                             (funcall f (car curr) x)))))))
    (rec init ls #'identity)))

(defun reduce-right (f ls)
  (r-reduce ls #'cdr #'null #'car
            f ls))

(defun take (n ls)
  (r-reduce 0 #'1+ #'(lambda (x) (<= n x)) #'(lambda (x) NIL)
            #'cons ls))

(defun drop (n ls)
  (r-reduce 0 #'1+ #'(lambda (x) (<= n x))
            #'identity
            #'(lambda (x y) y) ls))

(defun take-while (p ls)
  (r-reduce ls #'cdr #'(lambda (x) (not (funcall p (car x))))
            #'(lambda (x) NIL)
            #'cons ls))

(defun drop-while (p ls)
  (r-reduce ls #'cdr #'(lambda (x) (not (funcall p (car x))))
            #'identity
            #'(lambda (x y) y) ls))

; (reduce-right #'- '(3 1 4 1 5))      -> 10
; (take 5 '(3 1 4 1 5 9 2))            -> (3 1 4 1 5)
; (drop 5 '(3 1 4 1 5 9 2))            -> (9 2)
; (take-while #'oddp '(3 1 4 1 5 9 2)) -> (3 1)
; (drop-while #'oddp '(3 1 4 1 5 9 2)) -> (4 1 5 9 2)

reduce-right.clj

; These all have a same structure
; I think if we had an variant of reduce-right which accepts a condition to stop,
; we don't have to write loops directly on various situations.
; How the good abstraction is?
; -> r-reduce.clj of this gist

(use 'clojure.test)

(defn fold-right [f z coll]
  (loop [[h & r :as curr] coll acc identity]
    (if (nil? curr)
        (acc z)
        (recur r (comp acc #(f h %))))))

(defn reduce-right [f coll]
  (loop [[h & r] coll acc identity]
    (if (nil? r)
        (acc h)
        (recur r (comp acc #(f h %))))))

(defn my-take [n coll]
  (loop [i n [h & r] coll acc identity]
    (if (or (nil? r) (<= i 0))
        (acc '())
        (recur (dec i) r (comp acc #(cons h %))))))

(defn my-drop [n coll]
  (loop [i (- n 1) [h & r] coll acc identity]
    (if (or (nil? r) (<= i 0))
        (acc r)
        (recur (dec i) r acc))))

(defn my-take-while [p coll]
  (loop [[h & r] coll acc identity]
    (if (or (nil? r) (not (p h)))
        (acc '())
        (recur r (comp acc #(cons h %))))))

(defn my-drop-while [p coll]
  (loop [[h & r] coll acc identity]
    (if (or (nil? r) (not (p (first r))))
        (acc r)
        (recur r acc ))))

(defn my-reverse [coll]
  (loop [[h & r] coll acc identity]
    (if (nil? r)
        (acc (list h))
        (recur r (comp acc #(concat % (list h)))))))

(deftest test-reduce-rights
  (are [expected result] (= expected result)
    (fold-right - 2 '(3 1 4 1 5 9))       3
    (reduce-right - '(3 1 4 1 5 9 2))     3
    (my-take 5 '(3 1 4 1 5 9 2))          '(3 1 4 1 5)
    (my-drop 5 '(3 1 4 1 5 9 2))          '(9 2)
    (my-take-while odd? '(3 1 4 1 5 9 2)) '(3 1)
    (my-drop-while odd? '(3 1 4 1 5 9 2)) '(4 1 5 9 2)
    (my-reverse '(3 1 4 1 5 9 2))         '(2 9 5 1 4 1 3)))

reduce-right.lisp

; These all have a same structure.
; I think if we had an variant of reduce-right which accepts a condition to stop,
; we don't have to write loops directly on various situations.
; How the good abstraction is?
; -> r-reduce.lisp of this gist

(defun reduce-right (f ls)
  (labels
    ((rec (lss cont)
       (if (null (cdr lss))
           (funcall cont (car lss))
           (rec (cdr lss)
                #'(lambda (x)
                    (funcall cont
                             (funcall f (car lss) x)))))))
    (rec ls #'identity)))

(defun my-take (n ls)
  (labels
    ((rec (i lss cont)
       (if (or (null (cdr lss)) (<= i 0))
           (funcall cont NIL)
           (rec (1- i)
                (cdr lss)
                #'(lambda (x)
                    (funcall cont
                             (cons (car lss) x)))))))
    (rec n ls #'identity)))

(defun my-drop (n ls)
  (labels
    ((rec (i lss cont)
       (if (or (null (cdr lss)) (<= i 0))
           (funcall cont (cdr lss))
           (rec (1- i)
                (cdr lss)
                #'(lambda (x)
                    (funcall cont x))))))
    (rec (1- n) ls #'identity)))

(defun my-take-while (p ls)
  (labels
    ((rec (lss cont)
       (if (or (null (cdr lss)) (not (funcall p (car lss))))
           (funcall cont NIL)
           (rec (cdr lss)
                #'(lambda (x)
                    (funcall cont (cons (car lss) x)))))))
    (rec ls #'identity)))

(defun my-drop-while (p ls)
  (labels
    ((rec (lss cont)
       (if (or (null (cdr lss)) (not (funcall p (cadr lss))))
           (funcall cont (cdr lss))
           (rec (cdr lss)
                #'(lambda (x)
                    (funcall cont x))))))
    (rec ls #'identity)))

; (reduce-right #'- '(3 1 4 1 5))       -> 10
; (my-take 5 '(3 1 4 1 5 9 2))          -> (3 1 4 1 5)
; (my-drop 5 '(3 1 4 1 5 9 2))          -> (9 2)
; (my-take-while odd? '(3 1 4 1 5 9 2)) -> (3 1)
; (my-drop-while odd? '(3 1 4 1 5 9 2)) -> (4 1 5 9 2)))

How stupid have I been!
'f' doesn't vary in the accumulated list.
We only have to keep 1st operands of 'f' in reversed order in a list.