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