viewcvs.cgi/types/boolean.ml

module type S =
sig
  type 'a elem
  type 'a t

  val equal : 'a t -> 'a t -> bool
  val compare: 'a t -> 'a t -> int
  val hash: 'a t -> int

  external get: 'a t -> ('a elem list * 'a elem list) list = "%identity"

  val empty : 'a t
  val full  : 'a t
  val cup   : 'a t -> 'a t -> 'a t
  val cap   : 'a t -> 'a t -> 'a t
  val diff  : 'a t -> 'a t -> 'a t
  val atom  : 'a elem -> 'a t

  val map : ('a elem-> 'b elem) -> 'a t -> 'b t
  val iter: ('a elem -> unit) -> 'a t -> unit
  val compute: empty:'d -> full:'c -> cup:('d -> 'c -> 'd) 
    -> cap:('c -> 'b -> 'c) -> diff:('c -> 'b -> 'c) ->
    atom:('a elem -> 'b) -> 'a t -> 'd
  val compute_bool: ('a elem -> 'b t) -> 'a t -> 'b t
    
  val print: string -> (Format.formatter -> 'a elem -> unit) -> 'a t ->
    (Format.formatter -> unit) list
    
    
  val check: 'a t -> unit
end

module Make(X : SortedList.ARG) = struct
  type 'a elem = 'a X.t
  module SList = SortedList.Make_transp(X)
  module SSList = SortedList.Make_transp
    (struct
       type 'a t = 'a SList.t * 'a SList.t
       let compare (x1,y1) (x2,y2) =
         let c = SList.compare x1 x2 in if c <> 0 then c
         else SList.compare y1 y2
       let equal (x1,y1) (x2,y2) =
         (SList.equal x1 x2) && (SList.equal y1 y2)
       let hash (x,y) =
         SList.hash x + 17 * SList.hash y
     end)
  type 'a t = 'a SSList.t
  let hash = SSList.hash
  let compare = SSList.compare
  let equal = SSList.equal

  external get: 'a t -> ('a elem list * 'a elem list) list = "%identity"


let empty = [ ]
let full  = [ [],[] ]

let atom x = [ [x],[] ]

let may_remove (p1,n1) (p2,n2) =
  (SList.subset p2 p1) && (SList.subset n2 n1)

let cup t s = 
  if t == s then t
  else match (t,s) with
    | [],s -> s
    | t,[] -> t
    | [ [], [] ], _ | _, [ [], [] ] -> full
    | _ ->
        let s=
          SSList.filter 
            (fun (p,n) -> not (SSList.exists (may_remove (p,n)) t)) s in
        let t=
          SSList.filter 
            (fun (p,n) -> not (SSList.exists (may_remove (p,n)) s)) t in 
        SSList.cup s t

let tot = ref 0
let clean accu t =
  let rec aux accu = function
    | (p,n) :: rem ->
        if (List.exists (may_remove (p,n)) accu)
          || (List.exists (may_remove (p,n)) rem)
        then aux accu rem
        else aux ((p,n)::accu) rem 
    | [] -> accu
  in
  SSList.from_list (aux accu t)


let rec fold2_aux f a x = function
  | [] -> x
  | h :: t -> fold2_aux f a (f x a h) t

let rec fold2 f x l1 l2 =
  match l1 with
    | [] -> x
    | h :: t -> fold2 f (fold2_aux f h x l2) t l2

let cap s t =
  if s == t then s
  else if s == full then t
  else if t == full then s
  else if (s == empty) || (t == empty) then empty
  else
    let (lines1,common,lines2) = SSList.split s t in
    let rec aux lines (p1,n1) (p2,n2) =
        if (SList.disjoint p1 n2) && (SList.disjoint p2 n1) 
        then (SList.cup p1 p2, SList.cup n1 n2) :: lines
        else lines
    in
    clean (SSList.get common) (fold2 aux [] (SSList.get lines1) (SSList.get lines2))

let diff c1 c2 =
  if c2 == full then empty
  else if (c1 == empty) || (c2 == empty) then c1
  else
    let c1 = SSList.diff c1 c2 in
    let line (p,n) =
      let acc = SList.fold (fun acc a -> ([], [a]) :: acc) [] p in
      let acc = SList.fold (fun acc a -> ([a], []) :: acc) acc n in
      SSList.from_list acc
    in
    SSList.fold (fun c1 l -> cap c1 (line l)) c1 c2


let rec map f t =
  let lines =
    List.fold_left
      (fun lines (p,n) ->
         let p = SList.map f p and n = SList.map f n in
         if (SList.disjoint p n) then (p,n) :: lines else lines)
      []
      t
  in
  SSList.from_list lines

let iter f t =
  SSList.iter (fun (p,n) -> SList.iter f p; SList.iter f n) t

let compute ~empty ~full ~cup ~cap ~diff ~atom t =
  let line (p,n) =
    List.fold_left (fun accu x -> diff accu (atom x)) (
      List.fold_left (fun accu x -> cap accu (atom x)) full p
    ) n in
  List.fold_left (fun accu l -> cup accu (line l)) empty t
  
let compute_bool f = 
  compute ~empty ~full ~cup ~cap ~diff ~atom:f


let print any f =
  List.map 
    (function 
         (p1::p,n) -> 
           (fun ppf ->
              Format.fprintf ppf "@[%a" f p1;
              List.iter (fun x -> Format.fprintf ppf " &@ %a" f x) p;
              List.iter (fun x -> Format.fprintf ppf " \\@ %a" f x) n;
              Format.fprintf ppf "@]";
           )
       | ([],[]) -> 
           (fun ppf -> Format.fprintf ppf "%s" any)
       | ([],[n]) ->
           (fun ppf -> Format.fprintf ppf "@[%s \\ %a@]" any f n)
       | ([],n1::n) ->
           (fun ppf -> 
              Format.fprintf ppf "@[%s" any;
              List.iter (fun x -> Format.fprintf ppf " \\@ %a" f x) n;
              Format.fprintf ppf "@]";
           )
    )

let check b = ()
(*
  SSList.check b;
  SSList.iter 
    (fun (p,n) -> 
       SList.check p; 
       SList.check n; 
       assert (SList.disjoint p n)
    )
    b
*)

end

include Make(
  struct 
    type 'a t = 'a 
    let hash = Hashtbl.hash 
    let equal x y = x = y 
    let compare = compare 
  end)
1	abate	224	module type S =
2			sig
3			type 'a elem
4			type 'a t
5	abate	1
6	abate	224	val equal : 'a t -> 'a t -> bool
7			val compare: 'a t -> 'a t -> int
8			val hash: 'a t -> int
9
10			external get: 'a t -> ('a elem list * 'a elem list) list = "%identity"
11
12			val empty : 'a t
13			val full : 'a t
14			val cup : 'a t -> 'a t -> 'a t
15			val cap : 'a t -> 'a t -> 'a t
16			val diff : 'a t -> 'a t -> 'a t
17			val atom : 'a elem -> 'a t
18
19			val map : ('a elem-> 'b elem) -> 'a t -> 'b t
20	abate	225	val iter: ('a elem -> unit) -> 'a t -> unit
21	abate	224	val compute: empty:'d -> full:'c -> cup:('d -> 'c -> 'd)
22			-> cap:('c -> 'b -> 'c) -> diff:('c -> 'b -> 'c) ->
23			atom:('a elem -> 'b) -> 'a t -> 'd
24			val compute_bool: ('a elem -> 'b t) -> 'a t -> 'b t
25
26			val print: string -> (Format.formatter -> 'a elem -> unit) -> 'a t ->
27			(Format.formatter -> unit) list
28
29
30			val check: 'a t -> unit
31			end
32
33			module Make(X : SortedList.ARG) = struct
34			type 'a elem = 'a X.t
35	abate	225	module SList = SortedList.Make_transp(X)
36			module SSList = SortedList.Make_transp
37	abate	224	(struct
38			type 'a t = 'a SList.t * 'a SList.t
39			let compare (x1,y1) (x2,y2) =
40			let c = SList.compare x1 x2 in if c <> 0 then c
41			else SList.compare y1 y2
42			let equal (x1,y1) (x2,y2) =
43			(SList.equal x1 x2) && (SList.equal y1 y2)
44			let hash (x,y) =
45			SList.hash x + 17 * SList.hash y
46			end)
47			type 'a t = 'a SSList.t
48			let hash = SSList.hash
49			let compare = SSList.compare
50			let equal = SSList.equal
51
52			external get: 'a t -> ('a elem list * 'a elem list) list = "%identity"
53
54
55	abate	1	let empty = [ ]
56	abate	225	let full = [ [],[] ]
57	abate	1
58	abate	225	let atom x = [ [x],[] ]
59	abate	1
60			let may_remove (p1,n1) (p2,n2) =
61	abate	224	(SList.subset p2 p1) && (SList.subset n2 n1)
62	abate	1
63			let cup t s =
64			if t == s then t
65	abate	225	else match (t,s) with
66			\| [],s -> s
67			\| t,[] -> t
68			\| [ [], [] ], _ \| _, [ [], [] ] -> full
69			\| _ ->
70			let s=
71			SSList.filter
72			(fun (p,n) -> not (SSList.exists (may_remove (p,n)) t)) s in
73			let t=
74			SSList.filter
75			(fun (p,n) -> not (SSList.exists (may_remove (p,n)) s)) t in
76			SSList.cup s t
77	abate	1
78	abate	222	let tot = ref 0
79			let clean accu t =
80	abate	52	let rec aux accu = function
81			\| (p,n) :: rem ->
82			if (List.exists (may_remove (p,n)) accu)
83			\|\| (List.exists (may_remove (p,n)) rem)
84			then aux accu rem
85	abate	222	else aux ((p,n)::accu) rem
86			\| [] -> accu
87	abate	52	in
88	abate	224	SSList.from_list (aux accu t)
89	abate	52
90	abate	222
91	abate	52
92
93	abate	1	let rec fold2_aux f a x = function
94			\| [] -> x
95			\| h :: t -> fold2_aux f a (f x a h) t
96
97			let rec fold2 f x l1 l2 =
98			match l1 with
99			\| [] -> x
100			\| h :: t -> fold2 f (fold2_aux f h x l2) t l2
101
102			let cap s t =
103			if s == t then s
104			else if s == full then t
105			else if t == full then s
106			else if (s == empty) \|\| (t == empty) then empty
107			else
108	abate	224	let (lines1,common,lines2) = SSList.split s t in
109	abate	222	let rec aux lines (p1,n1) (p2,n2) =
110	abate	224	if (SList.disjoint p1 n2) && (SList.disjoint p2 n1)
111			then (SList.cup p1 p2, SList.cup n1 n2) :: lines
112	abate	222	else lines
113	abate	1	in
114	abate	225	clean (SSList.get common) (fold2 aux [] (SSList.get lines1) (SSList.get lines2))
115	abate	1
116			let diff c1 c2 =
117			if c2 == full then empty
118			else if (c1 == empty) \|\| (c2 == empty) then c1
119			else
120	abate	224	let c1 = SSList.diff c1 c2 in
121	abate	1	let line (p,n) =
122	abate	225	let acc = SList.fold (fun acc a -> ([], [a]) :: acc) [] p in
123			let acc = SList.fold (fun acc a -> ([a], []) :: acc) acc n in
124	abate	224	SSList.from_list acc
125	abate	1	in
126	abate	225	SSList.fold (fun c1 l -> cap c1 (line l)) c1 c2
127	abate	1
128
129			let rec map f t =
130			let lines =
131			List.fold_left
132			(fun lines (p,n) ->
133	abate	224	let p = SList.map f p and n = SList.map f n in
134			if (SList.disjoint p n) then (p,n) :: lines else lines)
135	abate	1	[]
136			t
137			in
138	abate	224	SSList.from_list lines
139	abate	1
140	abate	156	let iter f t =
141	abate	225	SSList.iter (fun (p,n) -> SList.iter f p; SList.iter f n) t
142	abate	1
143	abate	156	let compute ~empty ~full ~cup ~cap ~diff ~atom t =
144			let line (p,n) =
145			List.fold_left (fun accu x -> diff accu (atom x)) (
146			List.fold_left (fun accu x -> cap accu (atom x)) full p
147			) n in
148			List.fold_left (fun accu l -> cup accu (line l)) empty t
149	abate	1
150	abate	156	let compute_bool f =
151			compute ~empty ~full ~cup ~cap ~diff ~atom:f
152
153	abate	1
154			let print any f =
155			List.map
156			(function
157			(p1::p,n) ->
158			(fun ppf ->
159			Format.fprintf ppf "@[%a" f p1;
160			List.iter (fun x -> Format.fprintf ppf " &@ %a" f x) p;
161	abate	99	List.iter (fun x -> Format.fprintf ppf " \\@ %a" f x) n;
162	abate	1	Format.fprintf ppf "@]";
163			)
164			\| ([],[]) ->
165			(fun ppf -> Format.fprintf ppf "%s" any)
166			\| ([],[n]) ->
167	abate	99	(fun ppf -> Format.fprintf ppf "@[%s \\ %a@]" any f n)
168	abate	1	\| ([],n1::n) ->
169			(fun ppf ->
170			Format.fprintf ppf "@[%s" any;
171	abate	99	List.iter (fun x -> Format.fprintf ppf " \\@ %a" f x) n;
172	abate	1	Format.fprintf ppf "@]";
173			)
174			)
175
176	abate	225	let check b = ()
177			(*
178	abate	224	SSList.check b;
179	abate	225	SSList.iter
180	abate	1	(fun (p,n) ->
181	abate	224	SList.check p;
182			SList.check n;
183			assert (SList.disjoint p n)
184	abate	1	)
185			b
186	abate	225	*)
187	abate	1
188	abate	224	end
189
190			include Make(
191			struct
192			type 'a t = 'a
193			let hash = Hashtbl.hash
194			let equal x y = x = y
195			let compare = compare
196			end)