monads: new monad function m-reduce

2 files changed, 52 insertions, 16 deletions

diff --git a/src/clojure/contrib/monads.clj b/src/clojure/contrib/monads.clj
index 3b803580..04dd3f5a 100644
--- a/src/clojure/contrib/monads.clj
+++ b/src/clojure/contrib/monads.clj
@@ -1,7 +1,7 @@
 ;; Monads in Clojure
 
 ;; by Konrad Hinsen
-;; last updated March 24, 2009
+;; last updated April 21, 2009
 
 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
 ;; and distribution terms for this software are covered by the Eclipse
@@ -12,7 +12,8 @@
 ;; remove this notice, or any other, from this software.
 
 (ns clojure.contrib.monads
-  (:require [clojure.contrib.accumulators]))
+  (:require [clojure.contrib.accumulators])
+  (:use [clojure.contrib.def :only (name-with-attributes)]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -123,19 +124,34 @@
 (defmacro defmonadfn
   "Like defn, but for functions that use monad operations and are used inside
    a with-monad block."
+  {:arglists '([name docstring? attr-map? args expr]
+	       [name docstring? attr-map? (args expr) ...])}
+  [name & options]
+  (let [[name options]  (name-with-attributes name options)
+	fn-name (symbol (str *ns*) (format "m+%s+m" (str name)))
+	make-macro-body (fn [args]
+			  (list args `(list (quote ~fn-name)
+					    '~'m-bind '~'m-result
+					    '~'m-zero '~'m-plus
+					    ~@args)))
+	make-fn-body    (fn [args expr]
+			  (list (vec (concat ['m-bind 'm-result
+					      'm-zero 'm-plus] args))
+				expr))]
+    (if (list? (first options))
+      ; multiple arities
+      (let [arglists        (map first options)
+	    exprs           (map second options)
+	    ]
+	`(do
+	   (defmacro ~name ~@(map make-macro-body arglists))
+	   (defn ~fn-name ~@(map make-fn-body arglists exprs))))
+      ; single arity
+      (let [[args expr] options]
+	`(do
+	   (defmacro ~name ~@(make-macro-body args))
+	   (defn ~fn-name ~@(make-fn-body args expr)))))))
 
-  ([name doc-string args expr]
-    (let [doc-name (with-meta name {:doc doc-string})]
-      `(defmonadfn ~doc-name ~args ~expr)))
-
-  ([name args expr]
-   (let [fn-name (symbol (str *ns*) (format "m+%s+m" (str name)))]
-   `(do
-      (defmacro ~name ~args
-        (list (quote ~fn-name)
-	      '~'m-bind '~'m-result '~'m-zero '~'m-plus
-	      ~@args))
-      (defn ~fn-name [~'m-bind ~'m-result ~'m-zero ~'m-plus ~@args] ~expr)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -191,6 +207,19 @@
 	  m-result
 	  steps))
 
+(defmonadfn m-reduce
+  "Return the reduction of (m-lift 2 f) over the list of monadic values mvs
+   with initial value (m-result val)."
+  ([f mvs]
+   (if (empty? mvs)
+     (m-result (f))
+     (let [m-f (m-lift 2 f)]
+       (reduce m-f mvs))))
+  ([f val mvs]
+   (let [m-f    (m-lift 2 f)
+	 m-val  (m-result val)]
+     (reduce m-f m-val mvs))))
+
 (defmacro m-when
   "If test if logical true, return monadic value m-expr, else return
    (m-result nil)."
diff --git a/src/clojure/contrib/monads/examples.clj b/src/clojure/contrib/monads/examples.clj
index a216cb39..29a0b539 100644
--- a/src/clojure/contrib/monads/examples.clj
+++ b/src/clojure/contrib/monads/examples.clj
@@ -8,7 +8,7 @@
 
 (ns clojure.contrib.monads.examples
   (:use [clojure.contrib.monads
-	 :only (domonad with-monad m-lift m-seq m-when
+	 :only (domonad with-monad m-lift m-seq m-reduce m-when
 		sequence-m
 		maybe-m
 		state-m fetch-state set-state 
@@ -222,6 +222,13 @@
       [sum12 (reduce (m-lift 2 +) (replicate 12 rng))]
       (- sum12 6.)))
 
+; Such a reduction is often quite useful, so there's m-reduce predefined
+; to simplify it:
+(def gaussian2
+   (domonad state-m
+      [sum12 (m-reduce + (replicate 12 rng))]
+      (- sum12 6.)))
+
 ; The statistics should be strictly the same as above, as long as
 ; we use the same seed:
 (mean (take 1000 (value-seq gaussian2 1)))
@@ -232,7 +239,7 @@
 (with-monad state-m
    (def gaussian3
         ((m-lift 1 #(- % 6.))
-           (reduce (m-lift 2 +) (replicate 12 rng)))))
+           (m-reduce + (replicate 12 rng)))))
 
 ; Again, the statistics are the same:
 (mean (take 1000 (value-seq gaussian3 1)))