viewcvs.cgi/types/boolean.ml

type 'a t = ('a list * 'a list) list

let empty = [ ]

let full  = [ ([],[]) ]

let atom x = [ ([x],[]) ]

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

let cup t s = 
  if t == s then t
  else if t = empty then s else if s = empty then t
  else if (t = full) || (s = full) then full
  else 
    let s=
      List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) t)) s in
    let t=
      List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in 
    SortedList.cup s t

let clean 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
  List.rev (aux [] 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) = SortedList.split s t in
    let lines =
      fold2 
        (fun lines (p1,n1) (p2,n2) ->
           if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1) 
           then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
           else lines)
        []
        lines1
        lines2
    in
    clean (SortedList.cup common (SortedList.from_list lines))

let diff c1 c2 =
  if c2 == full then empty
  else if (c1 == empty) || (c2 == empty) then c1
  else
    let c1 = SortedList.diff c1 c2 in
    let line (p,n) =
      let acc = List.fold_left (fun acc a -> ([], [a]) :: acc) [] p in
      let acc = List.fold_left (fun acc a -> ([a], []) :: acc) acc n in
      SortedList.from_list acc
    in
    List.fold_left (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 = SortedList.map f p and n = SortedList.map f n in
         if (SortedList.disjoint p n) then (p,n) :: lines else lines)
      []
      t
  in
  SortedList.from_list lines

let iter f t =
  List.iter (fun (p,n) -> List.iter f p; List.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 =
  SortedList.check b;
  List.iter 
    (fun (p,n) -> 
       SortedList.check p; 
       SortedList.check n; 
       assert (SortedList.disjoint p n)
    )
    b

1	abate	1	type 'a t = ('a list * 'a list) list
2
3			let empty = [ ]
4
5			let full = [ ([],[]) ]
6
7			let atom x = [ ([x],[]) ]
8
9			let may_remove (p1,n1) (p2,n2) =
10			(SortedList.subset p2 p1) && (SortedList.subset n2 n1)
11
12			let cup t s =
13			if t == s then t
14	abate	69	else if t = empty then s else if s = empty then t
15			else if (t = full) \|\| (s = full) then full
16	abate	1	else
17			let s=
18			List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) t)) s in
19			let t=
20			List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in
21			SortedList.cup s t
22
23	abate	52	let clean t =
24			let rec aux accu = function
25			\| (p,n) :: rem ->
26			if (List.exists (may_remove (p,n)) accu)
27			\|\| (List.exists (may_remove (p,n)) rem)
28			then aux accu rem
29			else aux((p,n) :: accu) rem
30			\| [] -> accu
31			in
32			List.rev (aux [] t)
33
34
35
36	abate	1	let rec fold2_aux f a x = function
37			\| [] -> x
38			\| h :: t -> fold2_aux f a (f x a h) t
39
40			let rec fold2 f x l1 l2 =
41			match l1 with
42			\| [] -> x
43			\| h :: t -> fold2 f (fold2_aux f h x l2) t l2
44
45			let cap s t =
46			if s == t then s
47			else if s == full then t
48			else if t == full then s
49			else if (s == empty) \|\| (t == empty) then empty
50			else
51			let (lines1,common,lines2) = SortedList.split s t in
52			let lines =
53			fold2
54			(fun lines (p1,n1) (p2,n2) ->
55			if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1)
56			then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
57			else lines)
58			[]
59			lines1
60			lines2
61			in
62	abate	52	clean (SortedList.cup common (SortedList.from_list lines))
63	abate	1
64			let diff c1 c2 =
65			if c2 == full then empty
66			else if (c1 == empty) \|\| (c2 == empty) then c1
67			else
68			let c1 = SortedList.diff c1 c2 in
69			let line (p,n) =
70			let acc = List.fold_left (fun acc a -> ([], [a]) :: acc) [] p in
71			let acc = List.fold_left (fun acc a -> ([a], []) :: acc) acc n in
72			SortedList.from_list acc
73			in
74			List.fold_left (fun c1 l -> cap c1 (line l)) c1 c2
75
76
77			let rec map f t =
78			let lines =
79			List.fold_left
80			(fun lines (p,n) ->
81			let p = SortedList.map f p and n = SortedList.map f n in
82			if (SortedList.disjoint p n) then (p,n) :: lines else lines)
83			[]
84			t
85			in
86			SortedList.from_list lines
87
88	abate	156	let iter f t =
89			List.iter (fun (p,n) -> List.iter f p; List.iter f n) t
90	abate	1
91	abate	156	let compute ~empty ~full ~cup ~cap ~diff ~atom t =
92			let line (p,n) =
93			List.fold_left (fun accu x -> diff accu (atom x)) (
94			List.fold_left (fun accu x -> cap accu (atom x)) full p
95			) n in
96			List.fold_left (fun accu l -> cup accu (line l)) empty t
97	abate	1
98	abate	156	let compute_bool f =
99			compute ~empty ~full ~cup ~cap ~diff ~atom:f
100
101	abate	1
102			let print any f =
103			List.map
104			(function
105			(p1::p,n) ->
106			(fun ppf ->
107			Format.fprintf ppf "@[%a" f p1;
108			List.iter (fun x -> Format.fprintf ppf " &@ %a" f x) p;
109	abate	99	List.iter (fun x -> Format.fprintf ppf " \\@ %a" f x) n;
110	abate	1	Format.fprintf ppf "@]";
111			)
112			\| ([],[]) ->
113			(fun ppf -> Format.fprintf ppf "%s" any)
114			\| ([],[n]) ->
115	abate	99	(fun ppf -> Format.fprintf ppf "@[%s \\ %a@]" any f n)
116	abate	1	\| ([],n1::n) ->
117			(fun ppf ->
118			Format.fprintf ppf "@[%s" any;
119	abate	99	List.iter (fun x -> Format.fprintf ppf " \\@ %a" f x) n;
120	abate	1	Format.fprintf ppf "@]";
121			)
122			)
123
124			let check b =
125			SortedList.check b;
126			List.iter
127			(fun (p,n) ->
128			SortedList.check p;
129			SortedList.check n;
130			assert (SortedList.disjoint p n)
131			)
132			b
133