Monads: new writer monad, enhanced maybe-t transformer, new sequence-t transformer

2 files changed, 139 insertions, 10 deletions

diff --git a/src/clojure/contrib/monads.clj b/src/clojure/contrib/monads.clj
index f0a9ebc5..68c8b534 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 January 8, 2009
+;; last updated January 24, 2009
 
 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
 ;; and distribution terms for this software are covered by the Eclipse
@@ -11,7 +11,8 @@
 ;; agreeing to be bound by the terms of this license.  You must not
 ;; remove this notice, or any other, from this software.
 
-(ns clojure.contrib.monads)
+(ns clojure.contrib.monads
+  (:require [clojure.contrib.accumulators]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -233,6 +234,32 @@
 (defn fetch-state []
   (update-state identity))
 
+; Writer monad
+(defn writer
+  "Monad describing computations that accumulate data on the side, e.g. for
+   logging. The monadic values have the structure [value log]. Any of the
+   accumulators from clojure.contrib.accumulators can be used for storing the
+   log data. Its empty value is passed as a parameter."
+  [empty-accumulator]
+  (monad
+     [m-result  (fn m-result-writer [v]
+	          [v empty-accumulator])
+      m-bind    (fn m-bind-writer [mv f]
+	          (let [[v1 a1] mv
+			[v2 a2] (f v1)]
+		    [v2 (clojure.contrib.accumulators/combine a1 a2)]))
+     ]))
+
+(defmonadfn write [v]
+  (let [[_ a] (m-result nil)]
+    [nil (clojure.contrib.accumulators/add a v)]))
+
+(defn listen [mv]
+  (let [[v a] mv] [[v a] a]))
+
+(defn censor [f mv]
+  (let [[v a] mv] [v (f a)]))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -242,14 +269,57 @@
 
 (defn maybe-t
   "Monad transformer that transforms a monad m into a monad in which
-   the base values can be invalid (represented by nil)."
+   the base values can be invalid (represented by nothing, which defaults
+   to nil). The third argument chooses if m-zero and m-plus are inherited
+   from the base monad (use :m-plus-from-base) or adopt maybe-like
+   behaviour (use :m-plus-from-maybe)."
+  ([m] (maybe-t m nil :m-plus-from-base))
+  ([m nothing which-m-plus]
+   (let [combined-m-zero
+	 (cond
+	  (identical? which-m-plus :m-plus-from-base)
+	  (with-monad m m-zero)
+	  (identical? which-m-plus :m-plus-from-maybe)
+	  (with-monad m (m-result nothing))
+	  :else ::undefined)
+	 combined-m-plus
+	 (cond
+	  (identical? which-m-plus :m-plus-from-base)
+	  (with-monad m m-plus)
+	  (identical? which-m-plus :m-plus-from-maybe)
+	  (with-monad m
+	    (fn [& mvs]
+	      (m-result (loop [mv (first mvs)]
+			  (if (nil? mv)
+			    nothing
+			    (let [v (m-bind mv identity)]
+			      (if (identical? v nothing)
+				(recur (rest mvs))
+				v)))))))
+	  :else ::undefined)]
+     (monad [m-result (with-monad m
+		        m-result)
+	     m-bind   (with-monad m
+		        (fn m-bind-maybe-t [mv f]
+			  (m-bind mv
+				  (fn [x]
+				    (if (identical? x nothing)
+				      (m-result nothing)
+				      (f x))))))
+	     m-zero   combined-m-zero
+	     m-plus   combined-m-plus
+	     ]))))
+
+(defn sequence-t
+  "Monad transformer that transforms a monad m into a monad in which
+   the base values are sequences."
   [m]
   (monad [m-result (with-monad m
-		     m-result)
+		     (fn m-result-sequence-t [v]
+		       (m-result (list v))))
 	  m-bind   (with-monad m
-		     (fn m-bind-maybe-t [mv f]
+		     (fn m-bind-sequence-t [mv f]
 		       (m-bind mv
-			       (fn [x]
-				 (if (nil? x) (m-result nil) (f x))))))
-	  m-zero   (with-monad m m-zero)
-	  m-plus   (with-monad m m-plus)]))
+			       (fn [xs]
+				 (apply concat (map f xs))))))
+	  ]))
diff --git a/src/clojure/contrib/monads/examples.clj b/src/clojure/contrib/monads/examples.clj
index 2cb2d5ce..89b9bb68 100644
--- a/src/clojure/contrib/monads/examples.clj
+++ b/src/clojure/contrib/monads/examples.clj
@@ -6,7 +6,9 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(use 'clojure.contrib.monads)
+(ns clojure.contrib.monads.examples
+  (:use clojure.contrib.monads)
+  (:require (clojure.contrib [accumulators :as accu])))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -244,6 +246,63 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
+;;  Logging with the writer monad
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; A basic logging example
+(domonad (writer accu/empty-string)
+  [x (m-result 1)
+   _ (write "first step\n")
+   y (m-result 2)
+   _ (write "second step\n")]
+  (+ x y))
+
+; For a more elaborate application, let's trace the recursive calls of
+; a naive implementation of a Fibonacci function. The starting point is:
+(defn fib [n]
+  (if (< n 2)
+    n
+    (let [n1 (dec n)
+	  n2 (dec n1)]
+      (+ (fib n1) (fib n2)))))
+
+; First we rewrite it to make every computational step explicit
+; in a let expression:
+(defn fib [n]
+  (if (< n 2)
+    n
+    (let [n1 (dec n)
+	  n2 (dec n1)
+	  f1 (fib n1)
+	  f2 (fib n2)]
+      (+ f1 f2))))
+
+; Next, we replace the let by a domonad in a writer monad that uses a
+; vector accumulator. We can then place calls to write in between the
+; steps, and obtain as a result both the return value of the function
+; and the accumulated trace values.
+(with-monad (writer accu/empty-vector)
+
+  (defn fib-trace [n]
+    (if (< n 2)
+      (m-result n)
+      (domonad
+        [n1 (m-result (dec n))
+	 n2 (m-result (dec n1))
+	 f1 (fib-trace n1)
+	 _  (write [n1 f1])
+	 f2 (fib-trace n2)
+	 _  (write [n2 f2])
+	 ]
+	(+ f1 f2))))
+
+)
+
+(fib-trace 5)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
 ;; Sequences with undefined value: the maybe-t monad transformer
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;