Commit c18b8b05 authored by Pietro Abate's avatar Pietro Abate
Browse files

Fix multiple bugs in the function Tallying.norm

parent 410fcd0c
...@@ -189,5 +189,5 @@ module Var (X : T) = struct ...@@ -189,5 +189,5 @@ module Var (X : T) = struct
let equal t1 t2 = (compare t1 t2) = 0 let equal t1 t2 = (compare t1 t2) = 0
let dump ppf = function let dump ppf = function
|`Atm x -> X.dump ppf x |`Atm x -> X.dump ppf x
|`Var x -> String.dump ppf x |`Var x -> Format.fprintf ppf "`$%a" String.dump x
end end
...@@ -9,8 +9,23 @@ let parse_typ s = ...@@ -9,8 +9,23 @@ let parse_typ s =
Types.descr nodepat Types.descr nodepat
;; ;;
let cup = Types.Tallying.CS.S.cup
let cap = Types.Tallying.CS.cap
let singleton = Types.Tallying.CS.singleton
let norm_tests = [ let norm_tests = [
"Int \\ (`$A | `$B)", [[(false,`Var "A",parse_typ "Int \\ `$B")]]; "Int \\ (`$A | `$B)", singleton (false,`Var "A",parse_typ "Int \\ `$B");
"(`$A -> Int) \\ (`$B -> `$B)",
cup
(singleton (true,`Var "B",parse_typ "Empty"))
(cap
(singleton (false , `Var "B",parse_typ "`$A"))
(singleton (false , `Var "B",parse_typ "Int"))
);
"`$B", singleton (true,`Var "B",parse_typ "Empty");
"`$B \\ `$A", singleton (false , `Var "B",parse_typ "`$A");
"Int \\ `$B", singleton (false , `Var "B",parse_typ "Int");
"(Int & Bool -> Int) \\ (`$A -> `$B)"
] ]
let test_norm = let test_norm =
......
...@@ -42,6 +42,7 @@ sig ...@@ -42,6 +42,7 @@ sig
val cap : t -> t -> t val cap : t -> t -> t
val diff : t -> t -> t val diff : t -> t -> t
val atom : elem -> t val atom : elem -> t
val neg_atom : elem -> t
(* vars a : return a bdd that is ( Any ^ Var a ) *) (* vars a : return a bdd that is ( Any ^ Var a ) *)
val vars : Custom.var -> t val vars : Custom.var -> t
...@@ -54,7 +55,7 @@ sig ...@@ -54,7 +55,7 @@ sig
val is_empty : t -> bool val is_empty : t -> bool
val print: string -> t -> (Format.formatter -> unit) list val print: ?f:(Format.formatter -> elem -> unit) -> t -> (Format.formatter -> unit) list
val trivially_disjoint: t -> t -> bool val trivially_disjoint: t -> t -> bool
...@@ -189,10 +190,10 @@ struct ...@@ -189,10 +190,10 @@ struct
| `False -> () | `False -> ()
| _ -> b (); Format.fprintf ppf "@[~%a@] & @[(%a)@]" f x (print f) n) | _ -> b (); Format.fprintf ppf "@[~%a@] & @[(%a)@]" f x (print f) n)
let print a = function let print ?(f=X.dump) = function
| `True -> [ fun ppf -> Format.fprintf ppf "%s" a ] | `True -> [] (* [] a bdd cannot be of this type *)
| `False -> [] | `False -> [ fun ppf -> Format.fprintf ppf "Empty" ]
| c -> [ fun ppf -> print X.dump ppf c ] | c -> [ fun ppf -> print f ppf c ]
(* return a list of pairs, where each pair holds the list (* return a list of pairs, where each pair holds the list
* of positive and negative elements on a branch *) * of positive and negative elements on a branch *)
......
...@@ -1512,13 +1512,15 @@ struct ...@@ -1512,13 +1512,15 @@ struct
(empty, d) in (empty, d) in
let add u = slot.def <- u :: slot.def in let add u = slot.def <- u :: slot.def in
if (non_empty seq) then if (non_empty seq) then add (Regexp (decompile seq));
add (Regexp (decompile seq));
List.iter (* pairs *)
(fun (t1,t2) -> add (Pair (prepare t1, prepare t2))) List.iter (fun (t1,t2) ->
(Product.get not_seq); add (Pair (prepare t1, prepare t2))
List.iter ) (Product.get not_seq);
(fun (t1,t2) ->
(* xml pairs *)
List.iter (fun (t1,t2) ->
try try
let n = DescrPairMap.find (t1,t2) !named_xml in let n = DescrPairMap.find (t1,t2) !named_xml in
add (Name n) add (Name n)
...@@ -1532,26 +1534,30 @@ struct ...@@ -1532,26 +1534,30 @@ struct
(fun (ta,tb) -> (fun (ta,tb) ->
add (Xml (tag, prepare ta, prepare tb))) add (Xml (tag, prepare ta, prepare tb)))
(Product.get t2); (Product.get t2);
) ) (Product.get ~kind:`XML not_seq);
((*Product.merge_same_2*) (Product.get ~kind:`XML not_seq));
List.iter (* records *)
(fun (r,some,none) -> List.iter (fun (r,some,none) ->
let r = LabelMap.map (fun (o,t) -> (o, prepare t)) r in let r = LabelMap.map (fun (o,t) -> (o, prepare t)) r in
add (Record (r,some,none))) add (Record (r,some,none))
(Record.get not_seq); ) (Record.get not_seq);
(match Chars.is_char (BoolChars.leafconj not_seq.chars) with (match Chars.is_char (BoolChars.leafconj not_seq.chars) with
| Some c -> add (Char c) | Some c -> add (Char c)
| None -> | None ->
List.iter (fun x -> add (Atomic x)) (BoolChars.print "" not_seq.chars)); List.iter (fun x -> add (Atomic x)) (BoolChars.print not_seq.chars));
List.iter (fun x -> add (Atomic x)) (BoolIntervals.print "" not_seq.ints); List.iter (fun x -> add (Atomic x)) (BoolIntervals.print not_seq.ints);
List.iter (fun x -> add (Atomic x)) (BoolAtoms.print "" not_seq.atoms); List.iter (fun x -> add (Atomic x)) (BoolAtoms.print not_seq.atoms);
List.iter (fun x -> add (Atomic x)) (Abstract.print not_seq.abstract); List.iter (fun x -> add (Atomic x)) (Abstract.print not_seq.abstract);
List.iter
(fun (p,n) -> (* arrows *)
let aux (t,s) = prepare (descr t), prepare (descr s) in List.iter (fun (p,n) ->
let p = List.map aux p and n = List.map aux n in let aux (t,s) = prepare (descr t), prepare (descr s) in
add (Arrows (p,n))) let p = List.map aux p and n = List.map aux n in
(Pair.get (BoolPair.leafconj not_seq.arrow)); add (Arrows (p,n))
) (Pair.get (BoolPair.leafconj not_seq.arrow));
if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT")); if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT"));
slot.def <- List.rev slot.def; slot.def <- List.rev slot.def;
slot slot
...@@ -1663,14 +1669,13 @@ struct ...@@ -1663,14 +1669,13 @@ struct
| [] -> Format.fprintf ppf "Arrow" | [] -> Format.fprintf ppf "Arrow"
| (t,s)::l -> | (t,s)::l ->
Format.fprintf ppf "%a" (do_print_arrow pri) (t,s); Format.fprintf ppf "%a" (do_print_arrow pri) (t,s);
List.iter List.iter (fun (t,s) ->
(fun (t,s) -> Format.fprintf ppf " &@ %a" (do_print_arrow pri) (t,s)
Format.fprintf ppf " &@ %a" (do_print_arrow pri) (t,s) ) l
) l); );
List.iter List.iter (fun (t,s) ->
(fun (t,s) ->
Format.fprintf ppf " \\@ %a" (do_print_arrow pri) (t,s) Format.fprintf ppf " \\@ %a" (do_print_arrow pri) (t,s)
) n ) n
and do_print_arrow pri ppf (t,s) = and do_print_arrow pri ppf (t,s) =
if (pri = 3) then Format.fprintf ppf "("; if (pri = 3) then Format.fprintf ppf "(";
Format.fprintf ppf "%a -> %a" Format.fprintf ppf "%a -> %a"
...@@ -2198,14 +2203,23 @@ module Tallying = struct ...@@ -2198,14 +2203,23 @@ module Tallying = struct
module CS = struct module CS = struct
type key = (bool * Custom.var) type key = (bool * Custom.var)
(* constraint set : map to store constraints of the form (alpha,t) or (t,alpha) *)
module M = Map.Make(struct module M = Map.Make(struct
type t = key type t = key
let compare = Pervasives.compare let compare = Pervasives.compare
end) end)
(* Set of constraint sets *)
module S = Set.Make(struct module S = Set.Make(struct
type t = s M.t type t = Descr.s M.t
let compare = M.compare Pervasives.compare let compare = M.compare Descr.compare
end)
(* equation set : (s < alpha < t) stored as ( alpha -> (s,t) ) *)
module E = Map.Make(struct
type t = Custom.var
let compare = Pervasives.compare
end) end)
type cset = S.t type cset = S.t
...@@ -2218,18 +2232,48 @@ module Tallying = struct ...@@ -2218,18 +2232,48 @@ module Tallying = struct
|(k,None,None) -> None |(k,None,None) -> None
|(k,Some v,None) -> Some v |(k,Some v,None) -> Some v
|(k,None,Some v) -> Some v |(k,None,Some v) -> Some v
|((true,v),Some x,Some y) -> Some (cup x y) |((true,v),Some x,Some y) -> Some (cap x y)
|((false,v),Some x,Some y) -> Some (cap x y) |((false,v),Some x,Some y) -> Some (cup x y)
in in
M.merge f m1 m2 M.merge f m1 m2
let print ppf s =
let print_lst f ppf l =
let rec aux ppf = function
|[] -> Format.fprintf ppf "@."
|[h] -> Format.fprintf ppf "%a@." f h
|h::t -> Format.fprintf ppf "%a ,%a" f h aux t
in
match l with
|[] -> Format.fprintf ppf "{}"
|_ -> Format.fprintf ppf "{ %a }" aux l
in
print_lst (fun ppf -> fun m ->
print_lst (fun ppf -> fun ((b,`Var v),s) ->
if b then
Format.fprintf ppf "(`$%s,%a)" v Print.print s
else
Format.fprintf ppf "(%a,`$%s)" Print.print s v
) ppf (M.bindings m);
) ppf (S.elements s)
let sat = S.singleton M.empty let sat = S.singleton M.empty
let unsat = S.empty let unsat = S.empty
let cup = S.union let cup = S.union
let cap x y = let cap x y =
S.fold (fun m1 acc -> match S.is_empty x,S.is_empty y with
S.fold (fun m2 acc1 -> S.add (merge m1 m2) acc1) y acc |true,true -> S.empty
) x S.empty |false,true -> x
|true,false -> y
|false,false ->
let s =
S.fold (fun m1 acc ->
S.fold (fun m2 acc1 -> S.add (merge m1 m2) acc1) y acc
) x S.empty
in
s
end end
(* Correct ??? *) (* Correct ??? *)
...@@ -2237,49 +2281,65 @@ module Tallying = struct ...@@ -2237,49 +2281,65 @@ module Tallying = struct
let normchars (t,_) = if Chars.is_empty t then CS.sat else raise UnSatConstr let normchars (t,_) = if Chars.is_empty t then CS.sat else raise UnSatConstr
let normints (t,_) = if Intervals.is_empty t then CS.sat else raise UnSatConstr let normints (t,_) = if Intervals.is_empty t then CS.sat else raise UnSatConstr
let c_aux c atom acc l = let single_aux constr (b,v,p,n) =
List.fold_left (fun acc -> let aux f constr acc l =
function List.fold_left (fun acc ->
|`Var a -> c acc (atom (`Var a)) function
|`Atm a -> c acc (atom (`Atm a)) |`Var a -> cap acc (f(vars a))
) acc l |`Atm a -> cap acc (f(constr a))
) acc l
let capatoms (pos,neg) = in
let auxcap = c_aux BoolAtoms.cap BoolAtoms.atom BoolAtoms.full in let id = (fun x -> x) in
let auxcup = c_aux BoolAtoms.cup BoolAtoms.atom BoolAtoms.empty in let t = cap (aux id constr any p) (aux neg constr any n) in
{empty with atoms = BoolAtoms.diff (auxcap pos) (auxcup neg) } if b then neg t else t
let capchars (pos,neg) = let single_atoms = single_aux atom
let auxcap = c_aux BoolChars.cap BoolChars.atom BoolChars.full in
let auxcup = c_aux BoolChars.cup BoolChars.atom BoolChars.empty in let single_chars = single_aux char
{empty with chars = BoolChars.diff (auxcap pos) (auxcup neg) }
let single_ints = single_aux interval
let capints (pos,neg) =
let auxcap = c_aux BoolIntervals.cap BoolIntervals.atom BoolIntervals.full in let single_times = single_aux (fun p -> { empty with times = BoolPair.atom (`Atm p) })
let auxcup = c_aux BoolIntervals.cup BoolIntervals.atom BoolIntervals.empty in
{empty with ints = BoolIntervals.diff (auxcap pos) (auxcup neg) } let single_arrow = single_aux (fun p -> { empty with arrow = BoolPair.atom (`Atm p) })
let captimes (pos,neg) =
let auxcap = c_aux BoolPair.cap BoolPair.atom BoolPair.full in
let auxcup = c_aux BoolPair.cup BoolPair.atom BoolPair.empty in
{ empty with times = BoolPair.diff (auxcap pos) (auxcup neg) }
let caparrow (pos,neg) =
let auxcap = c_aux BoolPair.cap BoolPair.atom BoolPair.full in
let auxcup = c_aux BoolPair.cup BoolPair.atom BoolPair.empty in
{ empty with arrow = BoolPair.diff (auxcap pos) (auxcup neg) }
(* check if there exists a toplevel varaible : fun (pos,neg) *) (* check if there exists a toplevel varaible : fun (pos,neg) *)
let toplevel cap norm_rec mem (p,n) = match (p,n) with let toplevel single norm_rec mem (p,n) = match (p,n) with
|([],(`Var x)::neg) -> CS.singleton (false,`Var x,cap ([],neg)) |([],(`Var x)::neg) ->
|((`Var x)::pos,[]) -> CS.singleton (true,`Var x, cap (pos,[])) (
Format.printf "single 1 = %a\n" Print.print (single (false,x,[],neg));
CS.singleton (false,`Var x,single (false,x,p,n))
)
|((`Var x)::pos,[]) ->
Format.printf "single 2 = %a\n" Print.print (single (true,x,pos,[]));
CS.singleton (true ,`Var x,single (true,x,pos,[]))
|((`Var x)::pos, (`Var y)::neg) -> |((`Var x)::pos, (`Var y)::neg) ->
(* XXX this compare must be changed *) (* XXX this compare must be changed *)
if Pervasives.compare (`Var x) (`Var y) < 0 then if Pervasives.compare (`Var x) (`Var y) < 0 then
CS.singleton (true,`Var x,cap (pos,n)) (
else CS.singleton (false, `Var y, cap (p,neg)) Format.printf "single 3 = %a\n" Print.print (single (true,x,pos,n));
|(_, (`Var x)::neg) -> CS.singleton (false,`Var x,cap (p,neg)) CS.singleton (true,`Var x,single (true,x,pos,n))
|((`Var x)::pos, _) -> CS.singleton (true,`Var x, cap (pos,n)) )
else
(
Format.printf "single 4 = %a\n" Print.print (single (false,y,p,neg));
CS.singleton (false, `Var y,single (false,y,p,neg))
)
|([`Atm a], (`Var x)::neg) ->
(
Format.printf "!! single 5 = %a\n" Print.print (single (false,x,p,neg));
CS.singleton (false,`Var x,single (false,x,p,neg))
)
|((`Var x)::pos, [`Atm _]) -> failwith "impossible5"
(*
Format.printf "!! single = %a\n" Print.print (single (pos,[],[],n));
CS.singleton (true ,`Var x,single (pos,[],[],n))
*)
|([`Atm t], []) -> norm_rec (t,mem) |([`Atm t], []) -> norm_rec (t,mem)
|([],[`Atm t]) -> failwith "impossible0" (* norm_rec (t,mem) *) |([],[`Atm t]) -> failwith "impossible0" (* norm_rec (t,mem) *)
|([],[]) -> failwith "impossible" |([],[]) -> failwith "impossible"
...@@ -2290,22 +2350,25 @@ module Tallying = struct ...@@ -2290,22 +2350,25 @@ module Tallying = struct
let rec norm ( (t,m) : (s * DescrSet.t)) = let rec norm ( (t,m) : (s * DescrSet.t)) =
if DescrSet.mem t m then CS.sat else begin if DescrSet.mem t m then CS.sat else begin
try try
let aux_base cap norm_aux acc l = let aux_base single norm_aux acc l =
List.fold_left (fun acc (pos,neg) -> List.fold_left (fun acc (pos,neg) ->
CS.cup acc (toplevel cap norm_aux m (pos,neg)) (*
Format.printf "top cap = %a V %a = %a\n" CS.print acc CS.print (toplevel single norm_aux m (pos,neg)) CS.print (CS.cap acc (toplevel single norm_aux m (pos,neg)));
*)
CS.cap acc (toplevel single norm_aux m (pos,neg))
) acc l ) acc l
in in
let accu = CS.sat in let accu = CS.sat in
let accu = aux_base capatoms normatoms accu (BoolAtoms.get t.atoms) in let accu = aux_base single_atoms normatoms accu (BoolAtoms.get t.atoms) in
let accu = aux_base capchars normchars accu (BoolChars.get t.chars) in let accu = aux_base single_chars normchars accu (BoolChars.get t.chars) in
let accu = aux_base capints normints accu (BoolIntervals.get t.ints) in let accu = aux_base single_ints normints accu (BoolIntervals.get t.ints) in
let accu = aux_base captimes normpair accu (BoolPair.get t.times) in let accu = aux_base single_times normpair accu (BoolPair.get t.times) in
let accu = aux_base single_times normpair accu (BoolPair.get t.xml) in
(* (*
let accu = aux_base accu subpair (BoolPair.get d.xml) in
let accu = aux_base accu subrecord (BoolRec.get d.record) in let accu = aux_base accu subrecord (BoolRec.get d.record) in
*) *)
let accu = aux_base caparrow normarrow accu (BoolPair.get t.arrow) in let accu = aux_base single_arrow normarrow accu (BoolPair.get t.arrow) in
CS.cap CS.sat accu accu
with UnSatConstr -> CS.unsat with UnSatConstr -> CS.unsat
end end
...@@ -2314,12 +2377,15 @@ module Tallying = struct ...@@ -2314,12 +2377,15 @@ module Tallying = struct
* [t1] ^ [t2] ^ [t1 \ s1] ^ [t2 \ s2] ^ * [t1] ^ [t2] ^ [t1 \ s1] ^ [t2 \ s2] ^
* [t1 \ s1 \ s1_1] ^ [t2 \ s2 \ s2_1 ] ^ * [t1 \ s1 \ s1_1] ^ [t2 \ s2 \ s2_1 ] ^
* [t1 \ s1 \ s1_1 \ s1_2] ^ [t2 \ s2 \ s2_1 \ s2_2 ] ^ ... * [t1 \ s1 \ s1_1 \ s1_2] ^ [t2 \ s2 \ s2_1 \ s2_2 ] ^ ...
* prod(p,n) = [t1] ^ [t2] ^ prod'(t1,t2,n)
* prod'(t1,t2,{s1,s2} v n) = [t1\s1] ^ prod'(t1\s1,t2,n) v
* [t2\s2] ^ prod'(t1,t2\s2,n)
* *) * *)
and normpair ( (t,mem) : (BoolPair.s * DescrSet.t) ) = and normpair ( (t,mem) : (BoolPair.s * DescrSet.t) ) =
let mem = DescrSet.add { empty with times = BoolPair.atom (`Atm t) } mem in let mem = DescrSet.add { empty with times = BoolPair.atom (`Atm t) } mem in
let norm_prod pos neg = let norm_prod pos neg =
let rec aux (t1 : s) (t2 : s ) = function let rec aux (t1 : s) (t2 : s ) = function
|[] -> CS.sat |[] -> CS.S.empty
|(s1,s2) :: rest -> |(s1,s2) :: rest ->
let z1 = diff t1 (descr s1) in let z1 = diff t1 (descr s1) in
let z2 = diff t2 (descr s2) in let z2 = diff t2 (descr s2) in
...@@ -2340,26 +2406,39 @@ module Tallying = struct ...@@ -2340,26 +2406,39 @@ module Tallying = struct
in in
List.fold_left (fun acc (p,n) -> CS.cap acc (norm_prod p n)) CS.sat (Pair.get t) List.fold_left (fun acc (p,n) -> CS.cap acc (norm_prod p n)) CS.sat (Pair.get t)
(* *) (* arrow(p,{t1 -> t2}) = [t1] ^ arrow'(t1,any \\ t2,p)
* arrow'(t1,acc,p) =
([t1\s1] ^ arrow'(t1\s1,acc,p)) v
([acc ^ {s2} \ t2] ^ arrow'(t1,acc ^ {s2},p))
P(Q v {a}) = {a} v P(Q) v {X v {a} | X \in P(Q) }
*)
and normarrow ((t,mem) : (BoolPair.s * DescrSet.t) ) = and normarrow ((t,mem) : (BoolPair.s * DescrSet.t) ) =
let mem = DescrSet.add { empty with arrow = BoolPair.atom (`Atm t) } mem in let mem = DescrSet.add { empty with arrow = BoolPair.atom (`Atm t) } mem in
let rec norm_arrow pos neg = let rec norm_arrow pos neg =
match neg with match neg with
|[] -> CS.sat |[] -> CS.S.empty
|(t0,s0)::rest -> |(t1,t2) :: n ->
let con1 = norm (descr t0, mem) in Format.printf "t1 = %a\n" Print.print (descr t1);
let con2 = aux (descr t0) any (descr s0) pos in let con1 = norm (descr t1, mem) in
let con0 = norm_arrow pos rest in Format.printf "neg con1 = %a\n" CS.print con1;
let con2 = aux (descr t1) (diff any (descr t2)) pos in
Format.printf "neg con2 = %a\n" CS.print con2;
let con0 = norm_arrow pos n in
CS.cup (CS.cup con1 con2) con0 CS.cup (CS.cup con1 con2) con0
and aux (t0 : s) ( acc : s ) (s0 : s) = function and aux t1 acc = function
|[] -> CS.sat |[] -> CS.S.empty
|(s1,s2) :: rest -> |(s1,s2) :: p ->
let t01 = diff t0 (descr s1) in let t1s1 = diff t1 (descr s1) in
let acc1 = cup acc (descr s2) in Format.printf "t1 \\ s1 = %a\n" Print.print t1s1;
let con1 = norm (t01, mem) in let acc1 = cap acc (descr s2) in
let con2 = norm (diff acc1 s0, mem) in let con1 = norm (t1s1, mem) in
let con10 = aux t01 acc s0 rest in Format.printf "pos con1 = %a\n" CS.print con1;
let con20 = aux t0 acc1 s0 rest in Format.printf "- t2 ^ acc ^ s2 = %a\n" Print.print acc1;
let con2 = norm (acc1, mem) in
Format.printf "pos con2 = %a\n" CS.print con2;
let con10 = aux t1s1 acc p in
let con20 = aux t1 acc1 p in
let con11 = CS.cup con1 con10 in let con11 = CS.cup con1 con10 in
let con22 = CS.cup con2 con20 in let con22 = CS.cup con2 con20 in
CS.cap con11 con22 CS.cap con11 con22
...@@ -2368,20 +2447,53 @@ module Tallying = struct ...@@ -2368,20 +2447,53 @@ module Tallying = struct
let norm t = norm (t,DescrSet.empty) let norm t = norm (t,DescrSet.empty)
(* let rec merge (cs,mem) =
let merge (c,mem) = CS.M.fold (fun (b,v) s acc -> match (b,v) with
CS.M.foldi (fun acc -> function |(true,v) ->
|(true,v) -> fun s -> begin try
try let t = CS.M.find (false,v) cs in
let t = CS.M.find (false,v) in
let x = diff s t in let x = diff s t in
if mem x mem then acc if DescrSet.mem x mem then acc
else else
S.cup acc (S.cap c (norm x)) let c1 = CS.cap (CS.S.singleton cs) (norm x) in
let c2 = CS.S.fold (fun m acc -> CS.cup acc (merge (m,DescrSet.add x mem))) c1 CS.sat in
CS.cap acc c2
with Not_found -> acc end
|(false,v) -> acc
) cs CS.sat
with Not_found -> acc let merge c = merge (c,DescrSet.empty)
|
) S.sat c (*
*) let solve cs =
CS.M.fold (fun (b,v) s acc -> match (b,v) with
|(true,v) ->
try
let t = CS.M.find (false,v) cs in
let b = fresh () in
CS.E.add v ((cup s b) cap t) acc
with Not_found ->
let b = fresh () in
CS.E.add v (cup s b)
|(false,v) ->
try
let t = CS.M.find (true,v) cs in
let b = fresh () in
CS.E.add v ((cup t b) cap s) acc
with Not_found ->
let b = fresh () in
CS.E.add v (cap s b)
) cs CS.E.empty