X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=code%2Fmonads.ml;h=d8725937adb384bb104ce7f1781636c03f2424e3;hp=3fba1f3216414caa0419bc04527f7bb6b2f64cbb;hb=67ed83b1ad44c7590cf7d7c1ec3a079bc5140a61;hpb=47b863bd1121e6f1617da773dc36253b8f6f4215

diff --git a/code/monads.ml b/code/monads.ml
index 3fba1f32..d8725937 100644
--- a/code/monads.ml
+++ b/code/monads.ml
@@ -38,7 +38,7 @@
  * making their implementations private. The interpreter won't let
  * let you freely interchange the `'a Reader_monad.m`s defined below
  * with `Reader_monad.env -> 'a`. The code in this library can see that
- * those are equivalent, but code outside the library can't. Instead, you'll 
+ * those are equivalent, but code outside the library can't. Instead, you'll
  * have to use operations like `run` to convert the abstract monadic types
  * to types whose internals you have free access to.
  *
@@ -55,9 +55,11 @@
  * derived from)
  *)
 
-exception Undefined
 
 (* Some library functions used below. *)
+
+exception Undefined
+
 module Util = struct
   let fold_right = List.fold_right
   let map = List.map
@@ -78,14 +80,13 @@ module Util = struct
   let undef = Obj.magic (fun () -> raise Undefined)
 end
 
-
-
 (*
  * This module contains factories that extend a base set of
  * monadic definitions with a larger family of standard derived values.
  *)
 
 module Monad = struct
+
   (*
    * Signature extenders:
    *   Make :: BASE -> S
@@ -114,7 +115,7 @@ module Monad = struct
      *     (Catch)   plus (unit a) v  ===  unit a
      *     (Distrib) plus u v >>= f   ===  plus (u >>= f) (v >>= f)
      * When no natural zero is available, use `let zero () = Util.undef`.
-     * The Make functor automatically detects for zero >>= ..., and 
+     * The Make functor automatically detects for zero >>= ..., and
      * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
      *)
     val zero : unit -> ('x,'a) m
@@ -338,10 +339,9 @@ module List_monad : sig
     (* note that second argument is an 'a list, not the more abstract 'a m *)
     (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
-(* TODO
-    val permute : 'a m -> 'a m m
-    val select : 'a m -> ('a * 'a m) m
-*)
+    val permute : ('x,'a) m -> ('x,('x,'a) m) m
+    val select : ('x,'a) m -> ('x,('a * ('x,'a) m)) m
+    val expose : ('x,'a) m -> ('x,'a list) Wrapped.m
   end
 end = struct
   module Base = struct
@@ -376,7 +376,7 @@ end = struct
     | [] -> zero ()
     | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
   module T(Wrapped : Monad.S) = struct
-    (* Wrapped.sequence ms  ===  
+    (* Wrapped.sequence ms  ===
          let plus1 u v =
            Wrapped.bind u (fun x ->
            Wrapped.bind v (fun xs ->
@@ -408,10 +408,30 @@ end = struct
         Wrapped.bind v (fun vs ->
         Wrapped.unit (Base.plus us vs)))
     end)
-(*
-    let permute : 'a m -> 'a m m
-    let select : 'a m -> ('a * 'a m) m
-*)
+
+   (* insert 3 {[1;2]} ~~> {[ {[3;1;2]}; {[1;3;2]}; {[1;2;3]} ]} *)
+   let rec insert a u =
+     plus
+     (unit (Wrapped.bind u (fun us -> Wrapped.unit (a :: us))))
+     (Wrapped.bind u (fun us -> match us with
+         | [] -> zero ()
+         | x::xs -> (insert a (Wrapped.unit xs)) >>= fun v -> unit (Wrapped.bind v (fun vs -> Wrapped.unit (x :: vs)))))
+
+   (* select {[1;2;3]} ~~> {[ (1,{[2;3]}); (2,{[1;3]}), (3;{[1;2]}) ]} *)
+   let rec select u =
+     Wrapped.bind u (fun us -> match us with
+         | [] -> zero ()
+         | x::xs -> plus (unit (x, Wrapped.unit xs))
+             (select (Wrapped.unit xs) >>= fun (x', xs') -> unit (x', Wrapped.bind xs' (fun ys -> Wrapped.unit (x :: ys)))))
+
+   (* permute {[1;2;3]} ~~> {[ {[1;2;3]}; {[2;1;3]}; {[2;3;1]}; {[1;3;2]}; {[3;1;2]}; {[3;2;1]} ]} *)
+
+   let rec permute u =
+     Wrapped.bind u (fun us -> match us with
+         | [] -> unit (zero ())
+         | x::xs -> permute (Wrapped.unit xs) >>= (fun v -> insert x v))
+
+    let expose u = u
   end
 end
 
@@ -530,6 +550,7 @@ module Reader_monad(Env : sig type env end) : sig
     val ask : ('x,env) m
     val asks : (env -> 'a) -> ('x,'a) m
     val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
+    val expose : ('x,'a) m -> env -> ('x,'a) Wrapped.m
   end
 end = struct
   type env = Env.env
@@ -568,6 +589,7 @@ end = struct
     let asks selector = ask >>= (fun e ->
       try unit (selector e)
       with Not_found -> fun e -> Wrapped.zero ())
+    let expose u = u
   end
 end
 
@@ -593,6 +615,8 @@ module State_monad(Store : sig type store end) : sig
     val gets : (store -> 'a) -> ('x,'a) m
     val put : store -> ('x,unit) m
     val puts : (store -> store) -> ('x,unit) m
+    (* val passthru : ('x,'a) m -> (('x,'a * store) Wrapped.result * store -> 'b) -> ('x,'b) m *)
+    val expose : ('x,'a) m -> store -> ('x,'a * store) Wrapped.m
   end
 end = struct
   type store = Store.store
@@ -637,6 +661,8 @@ end = struct
       with Not_found -> Wrapped.zero ()
     let put s = fun _ -> Wrapped.unit ((), s)
     let puts modifier = fun s -> Wrapped.unit ((), modifier s)
+    (* let passthru u f = fun s -> Wrapped.unit (f (Wrapped.run (u s), s), s) *)
+    let expose u = u
   end
 end
 
@@ -968,6 +994,7 @@ module Tree_monad : sig
     (* note that second argument is an 'a tree?, not the more abstract 'a m *)
     (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
+    val expose : ('x,'a) m -> ('x,'a tree option) Wrapped.m
   end
 end = struct
   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
@@ -1026,7 +1053,9 @@ end = struct
     end
     include BaseT
     let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
+    let expose u = u
   end
+
 end;;