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 == 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 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
    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 equal_list e l1 l2 =
  if List.length l1 <> List.length l2 then raise Recursive.NotEqual;
  List.iter2 e l1 l2

let equal_line e (p1,n1) (p2,n2) =
  equal_list e p1 p2;
  equal_list e n1 n2

let equal e a b =
  equal_list (equal_line e) a b


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	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	else if (t == full) \|\| (s == full) then full
15	else
16	let s=
17	List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) t)) s in
18	let t=
19	List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in
20	SortedList.cup s t
21
22	let rec fold2_aux f a x = function
23	\| [] -> x
24	\| h :: t -> fold2_aux f a (f x a h) t
25
26	let rec fold2 f x l1 l2 =
27	match l1 with
28	\| [] -> x
29	\| h :: t -> fold2 f (fold2_aux f h x l2) t l2
30
31	let cap s t =
32	if s == t then s
33	else if s == full then t
34	else if t == full then s
35	else if (s == empty) \|\| (t == empty) then empty
36	else
37	let (lines1,common,lines2) = SortedList.split s t in
38	let lines =
39	fold2
40	(fun lines (p1,n1) (p2,n2) ->
41	if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1)
42	then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
43	else lines)
44	[]
45	lines1
46	lines2
47	in
48	SortedList.cup common (SortedList.from_list lines)
49
50	let diff c1 c2 =
51	if c2 == full then empty
52	else if (c1 == empty) \|\| (c2 == empty) then c1
53	else
54	let c1 = SortedList.diff c1 c2 in
55	let line (p,n) =
56	let acc = List.fold_left (fun acc a -> ([], [a]) :: acc) [] p in
57	let acc = List.fold_left (fun acc a -> ([a], []) :: acc) acc n in
58	SortedList.from_list acc
59	in
60	List.fold_left (fun c1 l -> cap c1 (line l)) c1 c2
61
62
63	let rec map f t =
64	let lines =
65	List.fold_left
66	(fun lines (p,n) ->
67	let p = SortedList.map f p and n = SortedList.map f n in
68	if (SortedList.disjoint p n) then (p,n) :: lines else lines)
69	[]
70	t
71	in
72	SortedList.from_list lines
73
74
75
76	let equal_list e l1 l2 =
77	if List.length l1 <> List.length l2 then raise Recursive.NotEqual;
78	List.iter2 e l1 l2
79
80	let equal_line e (p1,n1) (p2,n2) =
81	equal_list e p1 p2;
82	equal_list e n1 n2
83
84	let equal e a b =
85	equal_list (equal_line e) a b
86
87
88	let print any f =
89	List.map
90	(function
91	(p1::p,n) ->
92	(fun ppf ->
93	Format.fprintf ppf "@[%a" f p1;
94	List.iter (fun x -> Format.fprintf ppf " &@ %a" f x) p;
95	List.iter (fun x -> Format.fprintf ppf " -@ %a" f x) n;
96	Format.fprintf ppf "@]";
97	)
98	\| ([],[]) ->
99	(fun ppf -> Format.fprintf ppf "%s" any)
100	\| ([],[n]) ->
101	(fun ppf -> Format.fprintf ppf "@[%s - %a@]" any f n)
102	\| ([],n1::n) ->
103	(fun ppf ->
104	Format.fprintf ppf "@[%s" any;
105	List.iter (fun x -> Format.fprintf ppf " -@ %a" f x) n;
106	Format.fprintf ppf "@]";
107	)
108	)
109
110	let check b =
111	SortedList.check b;
112	List.iter
113	(fun (p,n) ->
114	SortedList.check p;
115	SortedList.check n;
116	assert (SortedList.disjoint p n)
117	)
118	b
119