X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=code%2Ftree_monadize.ml;h=16d061060d3cd23d345789a64c9f096d42afd672;hp=d38800a7bf03ae49e699d6efe7a003c1bf06e1b1;hb=1b7446b685897f2463c3ffe680f3321fdb8900be;hpb=7e3d6cc411a3fb891cb6de18b19ce707e7160b92

diff --git a/code/tree_monadize.ml b/code/tree_monadize.ml
index d38800a7..16d06106 100644
--- a/code/tree_monadize.ml
+++ b/code/tree_monadize.ml
@@ -72,8 +72,8 @@ end;;
 type env = int -> int;;
 
 type 'a reader = env -> 'a;;
-let unit_reader a : 'a reader = fun e -> a;;
-let bind_reader (u : 'a reader) (f : 'a -> 'b reader) : 'b reader =
+let reader_unit a : 'a reader = fun e -> a;;
+let reader_bind (u : 'a reader) (f : 'a -> 'b reader) : 'b reader =
   fun e -> f (u e) e;;
 
 (* Now we supply the Reader monad as a parameter to Tree_monadizer.
@@ -81,39 +81,39 @@ let bind_reader (u : 'a reader) (f : 'a -> 'b reader) : 'b reader =
  * the monadize function specialized to the Reader monad *)
 module TreeReader = Tree_monadizer(struct
   type 'a m = 'a reader
-  let unit = unit_reader
-  let bind = bind_reader
+  let unit = reader_unit
+  let bind = reader_bind
 end);;
 
 
 type store = int;;
 
 type 'a state = store -> 'a * store;;
-let unit_state a : 'a state  = fun s -> (a, s);;
-let bind_state (u : 'a state) (f : 'a -> 'b state) : 'b state =
+let state_unit a : 'a state  = fun s -> (a, s);;
+let state_bind (u : 'a state) (f : 'a -> 'b state) : 'b state =
   fun s -> (let (a, s') = u s in (f a) s');;
 
 (* Make a TreeState module containing monadize specialized to the State monad *)
 module TreeState =  Tree_monadizer(struct
   type 'a m = 'a state
-  let unit = unit_state
-  let bind = bind_state
+  let unit = state_unit
+  let bind = state_bind
 end);;
 
 
-let unit_list a = [a];;
-let bind_list (u: 'a list) (f : 'a -> 'b list) : 'b list =
+let list_unit a = [a];;
+let list_bind (u: 'a list) (f : 'a -> 'b list) : 'b list =
   List.concat(List.map f u);;
 
 (* Make a TreeList module containing monadize specialized to the List monad *)
 module TreeList =  Tree_monadizer(struct
   type 'a m = 'a list
-  let unit = unit_list
-  let bind = bind_list
+  let unit = list_unit
+  let bind = list_bind
 end);;
 
 
-(* since the continuation monad is parameterized on two types---it's
+(* since the Continuation monad is parameterized on two types---it's
  * ('a,'r) cont not ('a) cont---we can't match the type ('a) m that
  * Tree_monadizer expects in its parameter. So we have to make a different
  * Tree_monadizer2 that takes a ('a,'x) m type constructor in its
@@ -135,15 +135,15 @@ end) = struct
 end;;
 
 type ('a,'r) cont = ('a -> 'r) -> 'r;;
-let unit_cont a : ('a,'r) cont = fun k -> k a;;
-let bind_cont (u: ('a,'r) cont) (f: 'a -> ('b,'r) cont) : ('b,'r) cont =
+let cont_unit a : ('a,'r) cont = fun k -> k a;;
+let cont_bind (u: ('a,'r) cont) (f: 'a -> ('b,'r) cont) : ('b,'r) cont =
   fun k -> u (fun a -> f a k);;
 
 (* Make a TreeCont module containing monadize specialized to the Cont monad *)
 module TreeCont =  Tree_monadizer2(struct
   type ('a,'r) m = ('a,'r) cont
-  let unit = unit_cont
-  let bind = bind_cont
+  let unit = cont_unit
+  let bind = cont_bind
 end);;
 
 
@@ -191,7 +191,7 @@ TreeList.monadize (fun i -> [ [i;i*i] ]) t1;;
 
 (* do nothing *)
 let initial_continuation = fun t -> t in
-TreeCont.monadize unit_cont t1 initial_continuation;;
+TreeCont.monadize cont_unit t1 initial_continuation;;
 
 (* convert tree to list of leaves *)
 let initial_continuation = fun t -> [] in
@@ -210,3 +210,26 @@ let initial_continuation = fun t -> 0 in
 TreeCont.monadize (fun a k -> 1 + k a) t1 initial_continuation;;
 
 
+
+
+(* Tree monad *)
+
+(* type 'a tree defined above *)
+let tree_unit (a: 'a) : 'a tree = Leaf a;;
+let rec tree_bind (u : 'a tree) (f : 'a -> 'b tree) : 'b tree =
+    match u with
+    | Leaf a -> f a
+    | Node (l, r) -> Node (tree_bind l f, tree_bind r f);;
+
+type 'a, treeTC_reader =
+		'a tree reader;;
+
+	let unit (a: 'a) : 'a tree reader =
+		M.unit (Leaf a);;
+
+	let rec bind (u : ('a, M) tree) (f : 'a -> ('b, M) tree) : ('b, M) tree =
+	    match u with
+	    | Leaf a -> M.bind (f a) (fun b -> M.unit (Leaf b))
+	    | Node (l, r) -> M.bind (bind l f) (fun l' ->
+							M.bind (bind r f) (fun r' ->
+								M.unit (Node (l', r'));;