Commit 031befa2 authored by Pietro Abate's avatar Pietro Abate
Browse files

Better handling of toplevel variables

parent 6a67e7bc
...@@ -139,14 +139,26 @@ module BoolChars : BoolVar.S with ...@@ -139,14 +139,26 @@ module BoolChars : BoolVar.S with
module TLV = struct module TLV = struct
open Var module Set = Set.Make(
struct
type t = (Var.var * bool)
let compare (v1,p1) (v2,p2) =
let c = Var.compare v1 v2 in
if c == 0 then
if p1 == p2 then 0
else if p1 then 1 else -1
else c
end)
(* s : top level variables (* s : top level variables
* f : all free variables in the subtree * f : all free variables in the subtree
* b : true if the type contains only variables *) * b : true if the type contains only variables *)
type t = { s : Set.t ; f : Set.t ; b : bool } type t = { s : Set.t ; f : Var.Set.t ; b : bool }
let empty = { s = Set.empty ; f = Set.empty ; b = true } let empty = { s = Set.empty ; f = Var.Set.empty ; b = true }
let singleton v = { s = Set.singleton v; f = Set.singleton v; b = true } let any = { s = Set.empty ; f = Var.Set.empty ; b = false }
let singleton (v,p) = { s = Set.singleton (v,p); f = Var.Set.singleton v; b = true }
(* return the max of top level variables *) (* return the max of top level variables *)
let max x = Set.max_elt x.s let max x = Set.max_elt x.s
...@@ -154,30 +166,30 @@ module TLV = struct ...@@ -154,30 +166,30 @@ module TLV = struct
let pair x y = { let pair x y = {
b = false ; b = false ;
s = Set.empty ; s = Set.empty ;
f = Set.union x.f y.f f = Var.Set.union x.f y.f
} }
let union x y = { let union x y = {
b = x.b && y.b; b = x.b && y.b;
s = Set.union x.s y.s ; s = Set.union x.s y.s ;
f = Set.union x.f y.f ; f = Var.Set.union x.f y.f ;
} }
let inter x y = { let inter x y = {
b = x.b && y.b; b = x.b && y.b;
s = Set.inter x.s y.s ; s = Set.inter x.s y.s ;
f = Set.inter x.f y.f ; f = Var.Set.inter x.f y.f ;
} }
let diff x y = { let diff x y = {
b = x.b && y.b; b = x.b && y.b;
s = Set.diff x.s y.s; s = Set.inter x.s (Set.fold (fun (v,p) acc -> Set.add (v,not p) acc) y.s Set.empty);
f = Set.diff x.f y.f; f = Var.Set.union x.f y.f;
} }
(* true if it contains only one variable *) (* true if it contains only one variable *)
let is_single x = x.b && (Set.cardinal x.f = 1) && (Set.cardinal x.s = 1) let is_single x = x.b && (Var.Set.cardinal x.f = 1) && (Set.cardinal x.s = 1)
let no_variables x = (x.b == false) && (Set.cardinal x.f = 0) let no_variables x = (x.b == false) && (Var.Set.cardinal x.f = 0)
end end
...@@ -388,7 +400,7 @@ let any = { ...@@ -388,7 +400,7 @@ let any = {
chars = BoolChars.full; chars = BoolChars.full;
abstract = Abstract.any; abstract = Abstract.any;
absent= false; absent= false;
toplvars = TLV.empty toplvars = TLV.any
} }
let non_constructed = let non_constructed =
...@@ -411,8 +423,9 @@ let record_fields x = ...@@ -411,8 +423,9 @@ let record_fields x =
{ empty with record = BoolRec.atom (`Atm (Rec.atom x)) } { empty with record = BoolRec.atom (`Atm (Rec.atom x)) }
let atom a = { empty with atoms = BoolAtoms.atom (`Atm a) } let atom a = { empty with atoms = BoolAtoms.atom (`Atm a) }
(* Atm = Any ^ a *)
let var a = { let var a = {
(* Atm = Any ^ a *)
times = BoolPair.vars a; times = BoolPair.vars a;
xml = BoolPair.vars a; xml = BoolPair.vars a;
arrow = BoolPair.vars a; arrow = BoolPair.vars a;
...@@ -422,7 +435,7 @@ let var a = { ...@@ -422,7 +435,7 @@ let var a = {
chars = BoolChars.vars a; chars = BoolChars.vars a;
abstract = Abstract.empty; abstract = Abstract.empty;
absent= false; absent= false;
toplvars = TLV.singleton a toplvars = TLV.singleton (a,true)
} }
let is_var t = TLV.is_single t.toplvars let is_var t = TLV.is_single t.toplvars
...@@ -2609,10 +2622,14 @@ module Tallying = struct ...@@ -2609,10 +2622,14 @@ module Tallying = struct
(* norm generates a constraint set for the costraint t <= 0 *) (* norm generates a constraint set for the costraint t <= 0 *)
let rec norm (t,mem) = let rec norm (t,mem) =
(* if is_var t then XXX else *) if DescrSet.mem t mem then CS.sat else begin (* if we already evaluated it, it is sat *)
if is_var t then
let (v,p) = TLV.max t.toplvars in
let s = if p then (Pos (v,empty)) else (Neg (any,v)) in
CS.singleton s
else
(* XXX if there is only one variable then is it A <= 0 or 1 <= A *) (* XXX if there is only one variable then is it A <= 0 or 1 <= A *)
if is_empty t then CS.sat else (* if it empty then it is sat *) if is_empty t then CS.sat else (* if it empty then it is sat *)
if DescrSet.mem t mem then CS.sat else begin (* if we already evaluated it, it is sat *)
let mem = DescrSet.add t mem in let mem = DescrSet.add t mem in
let aux single norm_aux acc l = big_prod (toplevel single norm_aux mem) acc l in let aux single norm_aux acc l = big_prod (toplevel single norm_aux mem) acc l in
...@@ -2693,7 +2710,6 @@ module Tallying = struct ...@@ -2693,7 +2710,6 @@ module Tallying = struct
P(Q v {a}) = {a} v P(Q) v {X v {a} | X \in P(Q) } P(Q v {a}) = {a} v P(Q) v {X v {a} | X \in P(Q) }
*) *)
(*
and normarrow (t,mem) = and normarrow (t,mem) =
let rec norm_arrow pos neg = let rec norm_arrow pos neg =
match neg with match neg with
...@@ -2717,8 +2733,7 @@ module Tallying = struct ...@@ -2717,8 +2733,7 @@ module Tallying = struct
CS.prod con11 con22 CS.prod con11 con22
in in
big_prod norm_arrow CS.sat (Pair.get t) big_prod norm_arrow CS.sat (Pair.get t)
*) (*
and normarrow (t,mem) = and normarrow (t,mem) =
let rec norm_arrow pos neg = let rec norm_arrow pos neg =
match neg with match neg with
...@@ -2743,6 +2758,7 @@ module Tallying = struct ...@@ -2743,6 +2758,7 @@ module Tallying = struct
CS.prod con11 con22 CS.prod con11 con22
in in
big_prod norm_arrow CS.sat (Pair.get t) big_prod norm_arrow CS.sat (Pair.get t)
*)
let memo_norm = DescrHash.create 17 let memo_norm = DescrHash.create 17
let norm t = let norm t =
...@@ -2803,7 +2819,7 @@ module Tallying = struct ...@@ -2803,7 +2819,7 @@ module Tallying = struct
(* if t containts only a toplevel variable and nothing else (* if t containts only a toplevel variable and nothing else
* means that the constraint is of the form (alpha,beta). *) * means that the constraint is of the form (alpha,beta). *)
if is_var t then begin if is_var t then begin
let beta = TLV.max t.toplvars in let (beta,_) = TLV.max t.toplvars in
let acc1 = aux beta (empty,any) acc in let acc1 = aux beta (empty,any) acc in
(* alpha <= beta --> { empty <= alpha <= beta ; empty <= beta <= any } *) (* alpha <= beta --> { empty <= alpha <= beta ; empty <= beta <= any } *)
if b then aux alpha (empty,t) acc1 if b then aux alpha (empty,t) acc1
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment