File: search_monad.ml

package info (click to toggle)
aac-tactics 8.6.1-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 396 kB
  • sloc: ml: 2,604; makefile: 34
file content (70 lines) | stat: -rw-r--r-- 2,036 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
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 [])