Skip to content

Instantly share code, notes, and snippets.

@kohyama
Created June 8, 2012 17:13
Show Gist options
  • Save kohyama/2896939 to your computer and use it in GitHub Desktop.
Save kohyama/2896939 to your computer and use it in GitHub Desktop.
R-reduce is an abstraction of folding operations from right to left
(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' 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)))
; 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)
; 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)))
; 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)))
@kohyama
Copy link
Author

kohyama commented Jun 12, 2012

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.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment