1 files changed, 70 insertions, 0 deletions
diff --git a/search_monad.ml b/search_monad.ml
new file mode 100644
index 0000000..09a6455
--- /dev/null
+++ b/search_monad.ml
@@ -0,0 +1,70 @@
+(***************************************************************************)
+(*  This is part of aac_tactics, it is distributed under the terms of the  *)
+(*         GNU Lesser General Public License version 3                     *)
+(*              (see file LICENSE for more details)                        *)
+(*                                                                         *)
+(*       Copyright 2009-2010: Thomas Braibant, Damien Pous.                *)
+(***************************************************************************)
+
+type 'a m = | F of 'a
+	    | N of 'a m list
+		 
+let fold (f : 'a -> 'b -> 'b) (m : 'a m) (acc : 'b) =
+  let rec aux acc = function
+      F x -> f x acc
+    | N l ->
+	(List.fold_left (fun acc x ->
+			   match x with
+			     | (N []) -> acc
+			     | x ->  aux acc x
+			) acc l)
+  in
+    aux acc m
+
+     
+let rec (>>) : 'a m -> ('a -> 'b m) -> 'b m =
+  fun m f ->
+    match m with
+      | F x -> f x
+      | N l ->
+	  N (List.fold_left (fun acc x ->
+			       match x with
+				 | (N []) -> acc
+				 | x ->  (x >> f)::acc
+			    ) [] l)
+
+let (>>|) (m : 'a m) (n :'a m) : 'a m = match (m,n) with
+  | N [],_	-> n
+  | _,N []	-> m
+  | F x, N l -> N (F x::l)
+  | N l, F x -> N (F x::l)
+  | x,y -> N [x;y]
+	
+let return : 'a -> 'a m                 =  fun x -> F x
+let fail : unit -> 'a m                 =  fun () ->  N []        
+
+let sprint f m =
+  fold (fun x acc -> Printf.sprintf "%s\n%s" acc (f x)) m ""
+let rec count = function
+  | F _ -> 1
+  | N l -> List.fold_left (fun acc x -> acc+count x) 0 l
+	
+let opt_comb f x y = match x with None -> f y  | _ -> x
+
+let rec choose = function
+  | F x -> Some x
+  | N l -> List.fold_left (fun acc x ->
+			       opt_comb choose acc x
+			    ) None l
+
+let is_empty = fun x -> choose x = None
+
+let to_list m = (fold (fun x acc -> x::acc) m [])
+ 
+let sort f m =
+  N (List.map (fun x -> F x) (List.sort f (to_list m)))
+
+(* preserve the structure of the heap *)
+let filter f m =
+  fold (fun x acc -> (if f x then return x else fail ()) >>| acc) m (N [])
+