viewcvs.cgi/types/normal.ml

module type S =
sig
  type t

  val any: t
  val empty: t
  val cup: t -> t -> t
  val cap: t -> t -> t
  val diff: t -> t -> t
  val is_empty: t -> bool
end

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

module Make(X1 : S)(X2 : S) =
struct
  type t = (X1.t * X2.t) list
  type cell = { mutable t1 : X1.t; mutable t2 : X2.t; next: cell }
      (* Quite ugly, isn't it ?
         I _want_ sum+records types in OCaml ! *)


(* Possible optimizations:
   - check whether t1 or t2 is empty initially
   - check s1 = t1 (structural equility)
*)
  let rec add root t1 t2 l =
    if (Obj.magic l = 0) then root := { t1 = t1; t2 = t2; next = !root }
    else
      match l with
          { t1 = s1; t2 = s2; next = next } ->
            let i = X1.cap t1 s1 in
            if X1.is_empty i then add root t1 t2 l.next
            else (
              l.t1 <- i; l.t2 <- X2.cup t2 s2;
              let k = X1.diff s1 t1 in
              if not (X1.is_empty k) then 
                root := { t1 = k; t2 = s2; next = !root };
              
              let j = X1.diff t1 s1 in
              if not (X1.is_empty j) then add root j t2 next
            )

  let rec get accu l =
    if Obj.magic l = 0 then accu 
    else get ((l.t1, l.t2)::accu) l.next

  let normal x =
    let res = ref (Obj.magic 0) in
    List.iter (fun (t1,t2) -> add res t1 t2 !res) x;
    get [] !res

  let rec bigcap_aux t1 t2 = function
    | (s1,s2)::rem -> bigcap_aux (X1.cap t1 s1) (X2.cap t2 s2) rem
    | [] -> (t1,t2)
  let bigcap = bigcap_aux X1.any X2.any


  let line res (p,n) =
    let (d1,d2) = bigcap p in
    if not ((X1.is_empty d1) || (X2.is_empty d2)) then
      (let resid = ref d1 in
       List.iter
         (fun (t1,t2) ->
            let t1 = X1.cap d1 t1 in
            if not (X1.is_empty t1) then
              (resid := X1.diff !resid t1;
               let t2 = X2.diff d2 t2 in
               if not (X2.is_empty t2) then add res t1 t2 !res
              )
         ) (normal n);
       if not (X1.is_empty !resid) then add res !resid d2 !res)
      
  let boolean_normal x =
    let res = ref (Obj.magic 0) in
    List.iter (line res) x;
    get [] !res

  let boolean =
    List.fold_left (fun accu x ->
                      let res = ref (Obj.magic 0) in
                      line res x;
                      get accu !res) []
                

  let pi1 =
    List.fold_left (fun accu (t1,t2) -> X1.cup accu t1) X1.empty

  let pi2 =
    List.fold_left (fun accu (t1,t2) -> X2.cup accu t2) X2.empty

  let pi2_restricted restr = 
    List.fold_left (fun accu (t1,t2) -> 
                      if X1.is_empty (X1.cap t1 restr) then accu 
                      else X2.cup accu t2) X2.empty
end
1	module type S =
2	sig
3	type t
4
5	val any: t
6	val empty: t
7	val cup: t -> t -> t
8	val cap: t -> t -> t
9	val diff: t -> t -> t
10	val is_empty: t -> bool
11	end
12
13	type 'a bool = ('a list * 'a list) list
14
15	module Make(X1 : S)(X2 : S) =
16	struct
17	type t = (X1.t * X2.t) list
18	type cell = { mutable t1 : X1.t; mutable t2 : X2.t; next: cell }
19	(* Quite ugly, isn't it ?
20	I _want_ sum+records types in OCaml ! *)
21
22
23	(* Possible optimizations:
24	- check whether t1 or t2 is empty initially
25	- check s1 = t1 (structural equility)
26	*)
27	let rec add root t1 t2 l =
28	if (Obj.magic l = 0) then root := { t1 = t1; t2 = t2; next = !root }
29	else
30	match l with
31	{ t1 = s1; t2 = s2; next = next } ->
32	let i = X1.cap t1 s1 in
33	if X1.is_empty i then add root t1 t2 l.next
34	else (
35	l.t1 <- i; l.t2 <- X2.cup t2 s2;
36	let k = X1.diff s1 t1 in
37	if not (X1.is_empty k) then
38	root := { t1 = k; t2 = s2; next = !root };
39
40	let j = X1.diff t1 s1 in
41	if not (X1.is_empty j) then add root j t2 next
42	)
43
44	let rec get accu l =
45	if Obj.magic l = 0 then accu
46	else get ((l.t1, l.t2)::accu) l.next
47
48	let normal x =
49	let res = ref (Obj.magic 0) in
50	List.iter (fun (t1,t2) -> add res t1 t2 !res) x;
51	get [] !res
52
53	let rec bigcap_aux t1 t2 = function
54	\| (s1,s2)::rem -> bigcap_aux (X1.cap t1 s1) (X2.cap t2 s2) rem
55	\| [] -> (t1,t2)
56	let bigcap = bigcap_aux X1.any X2.any
57
58
59	let line res (p,n) =
60	let (d1,d2) = bigcap p in
61	if not ((X1.is_empty d1) \|\| (X2.is_empty d2)) then
62	(let resid = ref d1 in
63	List.iter
64	(fun (t1,t2) ->
65	let t1 = X1.cap d1 t1 in
66	if not (X1.is_empty t1) then
67	(resid := X1.diff !resid t1;
68	let t2 = X2.diff d2 t2 in
69	if not (X2.is_empty t2) then add res t1 t2 !res
70	)
71	) (normal n);
72	if not (X1.is_empty !resid) then add res !resid d2 !res)
73
74	let boolean_normal x =
75	let res = ref (Obj.magic 0) in
76	List.iter (line res) x;
77	get [] !res
78
79	let boolean =
80	List.fold_left (fun accu x ->
81	let res = ref (Obj.magic 0) in
82	line res x;
83	get accu !res) []
84
85
86	let pi1 =
87	List.fold_left (fun accu (t1,t2) -> X1.cup accu t1) X1.empty
88
89	let pi2 =
90	List.fold_left (fun accu (t1,t2) -> X2.cup accu t2) X2.empty
91
92	let pi2_restricted restr =
93	List.fold_left (fun accu (t1,t2) ->
94	if X1.is_empty (X1.cap t1 restr) then accu
95	else X2.cup accu t2) X2.empty
96	end