Instantly share code, notes, and snippets.

Embed
What would you like to do?
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

This comment has been minimized.

Show comment
Hide comment
@kohyama

kohyama Jun 8, 2012

This is an answer of my question https://gist.github.com/2894687
See also
'fold-right' and 'reduce-right' in Clojure: https://gist.github.com/2893987 ,
'unfold' in Clojure: https://gist.github.com/2901487 and
'r-reduce' in Common Lisp: https://gist.github.com/2897303
.

Owner

kohyama commented Jun 8, 2012

This is an answer of my question https://gist.github.com/2894687
See also
'fold-right' and 'reduce-right' in Clojure: https://gist.github.com/2893987 ,
'unfold' in Clojure: https://gist.github.com/2901487 and
'r-reduce' in Common Lisp: https://gist.github.com/2897303
.

@kohyama

This comment has been minimized.

Show comment
Hide comment
@kohyama

kohyama Jun 9, 2012

The 'comp' version consumes a large stack as the nest version.
Using 'partial' doesn't resolve this problem.

Owner

kohyama commented Jun 9, 2012

The 'comp' version consumes a large stack as the nest version.
Using 'partial' doesn't resolve this problem.

@kohyama

This comment has been minimized.

Show comment
Hide comment
@kohyama

kohyama Jun 11, 2012

Hummm... Something ugly.
Should I treat 'init' and 'updt' as optional and set their defaults to 'coll' and 'next'?

Owner

kohyama commented Jun 11, 2012

Hummm... Something ugly.
Should I treat 'init' and 'updt' as optional and set their defaults to 'coll' and 'next'?

@kohyama

This comment has been minimized.

Show comment
Hide comment
@kohyama

kohyama Jun 11, 2012

Instead of reversing items in the list, which are operands, at the beggining of the calculation,
the new 'r-reduce' accumulates operators and reverse and apply it when stopping.
Now it became not to consume large stack but large heap. sigh...

Owner

kohyama commented Jun 11, 2012

Instead of reversing items in the list, which are operands, at the beggining of the calculation,
the new 'r-reduce' accumulates operators and reverse and apply it when stopping.
Now it became not to consume large stack but large heap. sigh...

@kohyama

This comment has been minimized.

Show comment
Hide comment
@kohyama

kohyama Jun 12, 2012

'comp' calls 'reverse' internally.
So I changed not to use 'reverse' and 'comp' but to 'comp'oseing manually.
And changed the order of arguments in order to omit some parameters.

Owner

kohyama commented Jun 12, 2012

'comp' calls 'reverse' internally.
So I changed not to use 'reverse' and 'comp' but to 'comp'oseing manually.
And changed the order of arguments in order to omit some parameters.

@kohyama

This comment has been minimized.

Show comment
Hide comment
@kohyama

kohyama 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.

Owner

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