Commit a8f46774 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Refactor the Bool/BoolVar code so that they share the same interface. Give...

Refactor the Bool/BoolVar code so that they share the same interface. Give access to the underlying atom module in BoolVar.
parent 6ee6ef2e
...@@ -42,8 +42,10 @@ types/var.cmo : misc/utils.cmo types/sortedList.cmi types/ident.cmo \ ...@@ -42,8 +42,10 @@ types/var.cmo : misc/utils.cmo types/sortedList.cmi types/ident.cmo \
misc/custom.cmo types/var.cmi misc/custom.cmo types/var.cmi
types/var.cmx : misc/utils.cmx types/sortedList.cmx types/ident.cmx \ types/var.cmx : misc/utils.cmx types/sortedList.cmx types/ident.cmx \
misc/custom.cmx types/var.cmi misc/custom.cmx types/var.cmi
types/boolVar.cmo : types/var.cmi misc/custom.cmo types/boolVar.cmi types/boolVar.cmo : types/var.cmi misc/custom.cmo misc/bool.cmi \
types/boolVar.cmx : types/var.cmx misc/custom.cmx types/boolVar.cmi types/boolVar.cmi
types/boolVar.cmx : types/var.cmx misc/custom.cmx misc/bool.cmx \
types/boolVar.cmi
types/types.cmo : types/var.cmi misc/utils.cmo misc/stats.cmi \ types/types.cmo : types/var.cmi misc/utils.cmo misc/stats.cmi \
types/sortedList.cmi misc/pretty.cmi misc/ns.cmi types/normal.cmi \ types/sortedList.cmi misc/pretty.cmi misc/ns.cmi types/normal.cmi \
types/intervals.cmi types/ident.cmo misc/encodings.cmi misc/custom.cmo \ types/intervals.cmi types/ident.cmo misc/encodings.cmi misc/custom.cmo \
...@@ -367,12 +369,13 @@ misc/html.cmi : ...@@ -367,12 +369,13 @@ misc/html.cmi :
types/compunit.cmi : types/compunit.cmi :
types/sortedList.cmi : misc/custom.cmo types/sortedList.cmi : misc/custom.cmo
misc/bool.cmi : misc/custom.cmo misc/bool.cmi : misc/custom.cmo
types/intervals.cmi : misc/custom.cmo types/intervals.cmi : misc/custom.cmo misc/bool.cmi
types/chars.cmi : misc/custom.cmo types/chars.cmi : misc/custom.cmo misc/bool.cmi
types/atoms.cmi : misc/ns.cmi misc/encodings.cmi misc/custom.cmo types/atoms.cmi : misc/ns.cmi misc/encodings.cmi misc/custom.cmo \
misc/bool.cmi
types/normal.cmi : types/normal.cmi :
types/var.cmi : types/sortedList.cmi misc/custom.cmo types/var.cmi : types/sortedList.cmi misc/custom.cmo
types/boolVar.cmi : types/var.cmi misc/custom.cmo types/boolVar.cmi : types/var.cmi misc/custom.cmo misc/bool.cmi
types/types.cmi : types/var.cmi misc/ns.cmi types/intervals.cmi \ types/types.cmi : types/var.cmi misc/ns.cmi types/intervals.cmi \
types/ident.cmo misc/custom.cmo types/chars.cmi types/boolVar.cmi \ types/ident.cmo misc/custom.cmo types/chars.cmi types/boolVar.cmi \
types/atoms.cmi types/atoms.cmi
......
...@@ -8,7 +8,6 @@ sig ...@@ -8,7 +8,6 @@ sig
include Custom.T include Custom.T
val get: t -> (elem list * elem list) list val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
val empty : t val empty : t
val full : t val full : t
......
...@@ -4,7 +4,6 @@ sig ...@@ -4,7 +4,6 @@ sig
type elem type elem
val get: t -> (elem list * elem list) list val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
val empty : t val empty : t
val full : t val full : t
...@@ -15,15 +14,10 @@ sig ...@@ -15,15 +14,10 @@ sig
val iter: (elem-> unit) -> t -> unit val iter: (elem-> unit) -> t -> unit
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b) val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) -> -> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:(elem -> 'b) -> t -> 'b atom:(elem -> 'b) -> t -> 'b
(*
val print: string -> (Format.formatter -> elem -> unit) -> t ->
(Format.formatter -> unit) list
*)
val trivially_disjoint : t -> t -> bool val trivially_disjoint : t -> t -> bool
end end
......
...@@ -74,7 +74,7 @@ val get_field_ascii : t -> string -> t ...@@ -74,7 +74,7 @@ val get_field_ascii : t -> string -> t
val get_variant : t -> string * t option val get_variant : t -> string * t option
val abstract : Types.Abstracts.abs -> 'a -> t val abstract : Types.Abstracts.T.t -> 'a -> t
val get_abstract : t -> 'a val get_abstract : t -> 'a
val mk_ref : Types.t -> t -> t val mk_ref : Types.t -> t -> t
......
...@@ -183,7 +183,7 @@ let validate_token_list s = ...@@ -183,7 +183,7 @@ let validate_token_list s =
Value.sequence (List.map validate_token (split_xml_S s)) Value.sequence (List.map validate_token (split_xml_S s))
let validate_interval interval type_name s = let validate_interval interval type_name s =
let integer = let integer =
let s = Utf8.get_str s in let s = Utf8.get_str s in
if (String.length s = 0) then simple_type_error "integer" if (String.length s = 0) then simple_type_error "integer"
else else
...@@ -401,7 +401,7 @@ let restrict name (base,_,_) facets cd v = ...@@ -401,7 +401,7 @@ let restrict name (base,_,_) facets cd v =
let b = (t,cd,v) in let b = (t,cd,v) in
reg name b; reg name b;
b b
let list name (item,_,_) cd v = let list name (item,_,_) cd v =
let name = add_xsd_prefix name in let name = add_xsd_prefix name in
let t = simple_list (Some name) item in let t = simple_list (Some name) item in
...@@ -410,7 +410,7 @@ let list name (item,_,_) cd v = ...@@ -410,7 +410,7 @@ let list name (item,_,_) cd v =
b b
let primitive name cd v = let primitive name cd v =
let name = add_xsd_prefix name in let name = add_xsd_prefix name in
let rec t = let rec t =
{ st_name = Some name; { st_name = Some name;
...@@ -425,37 +425,37 @@ let alias name b = ...@@ -425,37 +425,37 @@ let alias name b =
let name = add_xsd_prefix name in let name = add_xsd_prefix name in
reg name b reg name b
let any_simple_type = let any_simple_type =
primitive "anySimpleType" Builtin_defs.string validate_string primitive "anySimpleType" Builtin_defs.string validate_string
let string = let string =
primitive "string" Builtin_defs.string validate_string primitive "string" Builtin_defs.string validate_string
let _ = let _ =
primitive "boolean" Builtin_defs.bool validate_bool primitive "boolean" Builtin_defs.bool validate_bool
let _ = let _ =
primitive "hexBinary" Builtin_defs.string validate_hexBinary primitive "hexBinary" Builtin_defs.string validate_hexBinary
let _ = let _ =
primitive "base64Binary" Builtin_defs.string validate_base64Binary primitive "base64Binary" Builtin_defs.string validate_base64Binary
let _ = let _ =
primitive "anyURI" Builtin_defs.string validate_anyURI primitive "anyURI" Builtin_defs.string validate_anyURI
let _ = let _ =
primitive "duration" duration_type validate_duration primitive "duration" duration_type validate_duration
let _ = let _ =
primitive "dateTime" dateTime_type validate_dateTime primitive "dateTime" dateTime_type validate_dateTime
let _ = let _ =
primitive "time" time_type validate_time primitive "time" time_type validate_time
let _ = let _ =
primitive "date" date_type validate_date primitive "date" date_type validate_date
let _ = let _ =
primitive "gYearMonth" gYearMonth_type validate_gYearMonth primitive "gYearMonth" gYearMonth_type validate_gYearMonth
let _ = let _ =
primitive "gYear" gYear_type validate_gYear primitive "gYear" gYear_type validate_gYear
let _ = let _ =
primitive "gMonthDay" gMonthDay_type validate_gMonthDay primitive "gMonthDay" gMonthDay_type validate_gMonthDay
let _ = let _ =
primitive "gDay" gDay_type validate_gDay primitive "gDay" gDay_type validate_gDay
let _ = let _ =
primitive "gMonth" gMonth_type validate_gMonth primitive "gMonth" gMonth_type validate_gMonth
let decimal = let decimal =
primitive "decimal" Builtin_defs.float validate_decimal primitive "decimal" Builtin_defs.float validate_decimal
let _ = let _ =
...@@ -463,10 +463,10 @@ let _ = ...@@ -463,10 +463,10 @@ let _ =
alias "double" decimal alias "double" decimal
let _ = let _ =
List.iter (fun n -> alias n string) unsupported List.iter (fun n -> alias n string) unsupported
let int_type (name,min,max) = let int_type (name,min,max) =
let ival = match min,max with let ival = match min,max with
| Some min, Some max -> | Some min, Some max ->
let min = Intervals.V.mk min and max = Intervals.V.mk max in let min = Intervals.V.mk min and max = Intervals.V.mk max in
...@@ -478,17 +478,17 @@ let int_type (name,min,max) = ...@@ -478,17 +478,17 @@ let int_type (name,min,max) =
let min = Intervals.V.mk min in let min = Intervals.V.mk min in
Intervals.right min Intervals.right min
| None, None -> | None, None ->
Intervals.any Intervals.full
in in
ignore (primitive name (Types.interval ival) (validate_interval ival name)) ignore (primitive name (Types.interval ival) (validate_interval ival name))
let () = let () =
List.iter int_type [ List.iter int_type [
"integer", None, None; "integer", None, None;
"nonPositiveInteger", None, Some "0"; "nonPositiveInteger", None, Some "0";
"negativeInteger", None, Some "-1"; "negativeInteger", None, Some "-1";
"long", Some "-9223372036854775808", Some "9223372036854775807"; "long", Some "-9223372036854775808", Some "9223372036854775807";
"int", Some "-2147483648", Some "2147483647"; "int", Some "-2147483648", Some "2147483647";
"short", Some "-32768", Some "32767"; "short", Some "-32768", Some "32767";
"byte", Some "-128", Some "127"; "byte", Some "-128", Some "127";
"nonNegativeInteger", Some "0", None; "nonNegativeInteger", Some "0", None;
...@@ -496,16 +496,16 @@ let () = ...@@ -496,16 +496,16 @@ let () =
"unsignedInt", Some "0", Some "4294967295"; "unsignedInt", Some "0", Some "4294967295";
"unsignedShort", Some "0", Some "65535"; "unsignedShort", Some "0", Some "65535";
"unsignedByte", Some "0", Some "255"; "unsignedByte", Some "0", Some "255";
"positiveInteger", Some "1", None "positiveInteger", Some "1", None
] ]
let normalized_string =
let normalized_string =
restrict "normalizedString" string restrict "normalizedString" string
{ no_facets with whiteSpace = `Replace, false } { no_facets with whiteSpace = `Replace, false }
Builtin_defs.string validate_normalizedString Builtin_defs.string validate_normalizedString
let token = let token =
restrict "token" normalized_string restrict "token" normalized_string
{ no_facets with whiteSpace = `Collapse, false } { no_facets with whiteSpace = `Collapse, false }
Builtin_defs.string validate_token Builtin_defs.string validate_token
...@@ -695,5 +695,3 @@ let validate (_,_,v) = v ...@@ -695,5 +695,3 @@ let validate (_,_,v) = v
let of_st = function let of_st = function
| { st_name = Some n } -> get n | { st_name = Some n } -> get n
| _ -> assert false | _ -> assert false
...@@ -14,11 +14,11 @@ let rec iter_sep sep f = function ...@@ -14,11 +14,11 @@ let rec iter_sep sep f = function
| [] -> () | [] -> ()
| [ h ] -> f h | [ h ] -> f h
| h :: t -> f h; sep (); iter_sep sep f t | h :: t -> f h; sep (); iter_sep sep f t
let print_symbolset ns ppf = function let print_symbolset ns ppf = function
| SymbolSet.Finite l -> | SymbolSet.Finite l ->
iter_sep iter_sep
(fun () -> Format.fprintf ppf " |@ ") (fun () -> Format.fprintf ppf " |@ ")
(V.print_quote ppf) l (V.print_quote ppf) l
| SymbolSet.Cofinite t -> | SymbolSet.Cofinite t ->
Format.fprintf ppf "@[`%a" Ns.InternalPrinter.print_any_ns ns; Format.fprintf ppf "@[`%a" Ns.InternalPrinter.print_any_ns ns;
...@@ -41,37 +41,37 @@ let single s = match get s with ...@@ -41,37 +41,37 @@ let single s = match get s with
| _ -> raise Exit | _ -> raise Exit
let print_tag s = match get s with let print_tag s = match get s with
| `Finite [_, SymbolSet.Finite [a]] -> | `Finite [_, SymbolSet.Finite [a]] ->
Some (fun ppf -> Ns.InternalPrinter.print_tag ppf (V.value a)) Some (fun ppf -> Ns.InternalPrinter.print_tag ppf (V.value a))
| `Finite [ns, SymbolSet.Cofinite []] -> | `Finite [ns, SymbolSet.Cofinite []] ->
Some (fun ppf -> Ns.InternalPrinter.print_any_ns ppf ns) Some (fun ppf -> Ns.InternalPrinter.print_any_ns ppf ns)
| `Cofinite [] -> | `Cofinite [] ->
Some (fun ppf -> Format.fprintf ppf "_") Some (fun ppf -> Format.fprintf ppf "_")
| _ -> None | _ -> None
let print s = match get s with let print s = match get s with
| `Finite l -> | `Finite l ->
List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l
| `Cofinite [] -> | `Cofinite [] ->
[ fun ppf -> Format.fprintf ppf "Atom" ] [ fun ppf -> Format.fprintf ppf "Atom" ]
| `Cofinite l -> | `Cofinite l ->
[ fun ppf -> [ fun ppf ->
Format.fprintf ppf "Atom"; Format.fprintf ppf "Atom";
List.iter List.iter
(fun (ns,s) -> (fun (ns,s) ->
Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s) Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
l ] l ]
type 'a map = 'a Imap.t * 'a Imap.t * 'a option type 'a map = 'a Imap.t * 'a Imap.t * 'a option
let map_map f (m1,m2,o) = let map_map f (m1,m2,o) =
Imap.map f m1, Imap.map f m2, Imap.map f m1, Imap.map f m2,
(match o with Some x -> Some (f x) | None -> None) (match o with Some x -> Some (f x) | None -> None)
(* TODO: optimize this get_map *) (* TODO: optimize this get_map *)
let get_map q (mtags,mns,def) = let get_map q (mtags,mns,def) =
try Imap.find mtags (Upool.int q) try Imap.find mtags (Upool.int q)
with Not_found -> with Not_found ->
try Imap.find mns (Upool.int (fst (V.value q))) try Imap.find mns (Upool.int (fst (V.value q)))
with Not_found -> match def with with Not_found -> match def with
| None -> assert false | None -> assert false
...@@ -81,14 +81,14 @@ let mk_map l = ...@@ -81,14 +81,14 @@ let mk_map l =
let all_ns = ref [] in let all_ns = ref [] in
let all_tags = ref [] in let all_tags = ref [] in
let def = ref None in let def = ref None in
List.iter List.iter
(function (s,x) -> (function (s,x) ->
match get s with match get s with
| `Finite s -> | `Finite s ->
List.iter List.iter
(function (function
| (_, SymbolSet.Finite t) -> | (_, SymbolSet.Finite t) ->
List.iter List.iter
(fun tag -> all_tags := (Upool.int tag,x)::!all_tags) t (fun tag -> all_tags := (Upool.int tag,x)::!all_tags) t
| (ns, _) -> | (ns, _) ->
all_ns := (Upool.int ns,x)::!all_ns all_ns := (Upool.int ns,x)::!all_ns
...@@ -108,3 +108,9 @@ let contains_sample s t = ...@@ -108,3 +108,9 @@ let contains_sample s t =
| None, `Finite _ -> false | None, `Finite _ -> false
| Some (_,Some tag),_ -> contains tag t | Some (_,Some tag),_ -> contains tag t
| Some (ns, None),_ -> is_empty (diff (any_in_ns ns) t) | Some (ns, None),_ -> is_empty (diff (any_in_ns ns) t)
let trivially_disjoint = disjoint
let compute ~empty ~full ~cup ~cap ~diff ~atom b = assert false
let get _ = assert false
let iter _ = assert false
...@@ -13,11 +13,9 @@ module V : sig ...@@ -13,11 +13,9 @@ module V : sig
val to_string: t -> string val to_string: t -> string
end end
include Custom.T include Bool.S with type elem = V.t
val print : t -> (Format.formatter -> unit) list val print : t -> (Format.formatter -> unit) list
type elem = V.t
val empty : t val empty : t
val any : t val any : t
val full : t (* same as any *) val full : t (* same as any *)
......
...@@ -2,51 +2,17 @@ let (<) : int -> int -> bool = (<) ...@@ -2,51 +2,17 @@ let (<) : int -> int -> bool = (<)
let (>) : int -> int -> bool = (>) let (>) : int -> int -> bool = (>)
let (=) : int -> int -> bool = (=) let (=) : int -> int -> bool = (=)
(* this is the the of the Constructor container *)
module type E = sig
type elem
include Custom.T
val empty : t
val full : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
end
module type S = sig module type S = sig
type s module Atom : Bool.S
type elem = s Var.var_or_atom
include Custom.T
(* returns the union of all leaves in the BDD *)
val leafconj: t -> s
val get: t -> (elem list * elem list) list
(* val build : (elem list * elem list) list -> t*)
val empty : t
val full : t
(* same as full, but we keep it for the moment to avoid chaging
* the code everywhere *)
val any : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
val trivially_disjoint: t -> t -> bool include Bool.S with type elem = Atom.t Var.var_or_atom
(* vars a : return a bdd that is ( Any ^ Var a ) *) val var : Var.t -> t
val vars : Var.var -> t
val iter: (elem -> unit) -> t -> unit (** returns the union of all leaves in the BDD *)
val leafconj: t -> Atom.t
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:(elem -> 'b) -> t -> 'b
val is_empty : t -> bool val is_empty : t -> bool
...@@ -54,13 +20,8 @@ module type S = sig ...@@ -54,13 +20,8 @@ module type S = sig
val print : ?f:(Format.formatter -> elem -> unit) -> t -> (Format.formatter -> unit) list val print : ?f:(Format.formatter -> elem -> unit) -> t -> (Format.formatter -> unit) list
(*
val extractvars : t -> [> `Var of Var.t ] bdd * t
*)
end end
module type MAKE = functor (T : E) -> S with type s = T.t
(* ternary BDD (* ternary BDD
* where the nodes are Atm of X.t | Var of String.t * where the nodes are Atm of X.t | Var of String.t
* Variables are always before Values * Variables are always before Values
...@@ -79,26 +40,26 @@ module type MAKE = functor (T : E) -> S with type s = T.t ...@@ -79,26 +40,26 @@ module type MAKE = functor (T : E) -> S with type s = T.t
* *
* *) * *)
module Make (T : E) : S with type s = T.t = struct module Make (T : Bool.S) : S with module Atom = T and type elem = T.t Var.var_or_atom = struct
(* ternary decision trees . cf section 11.3.3 Frish PhD *) (* ternary decision trees . cf section 11.3.3 Frish PhD *)
(* plus variables *) (* plus variables *)
(* `Atm are containers (Atoms, Chars, Intervals, Pairs ... ) (* `Atm are containers (Atoms, Chars, Intervals, Pairs ... )
* `Var are String * `Var are String
*) *)
type s = T.t module Atom = T
type elem = s Var.var_or_atom type elem = T.t Var.var_or_atom
module X : Custom.T with type t = elem = Var.Make(T) module X : Custom.T with type t = elem = Var.Make(T)
type 'a bdd = type 'a bdd = False
[ `True | True
| `False | Split of int * 'a * ('a bdd) * ('a bdd) * ('a bdd)
| `Split of int * 'a * ('a bdd) * ('a bdd) * ('a bdd) ]
type t = elem bdd type t = elem bdd
let rec equal_aux eq a b = let rec equal_aux eq a b =
(a == b) || (a == b) ||
match (a,b) with match (a,b) with
| `Split (h1,x1,p1,i1,n1), `Split (h2,x2,p2,i2,n2) -> | Split (h1,x1,p1,i1,n1), Split (h2,x2,p2,i2,n2) ->
(h1 == h2) && (h1 == h2) &&
(equal_aux eq p1 p2) && (equal_aux eq i1 i2) && (equal_aux eq p1 p2) && (equal_aux eq i1 i2) &&
(equal_aux eq n1 n2) && (eq x1 x2) (equal_aux eq n1 n2) && (eq x1 x2)
...@@ -112,55 +73,55 @@ module Make (T : E) : S with type s = T.t = struct ...@@ -112,55 +73,55 @@ module Make (T : E) : S with type s = T.t = struct
let rec compare a b = let rec compare a b =
if (a == b) then 0 if (a == b) then 0
else match (a,b) with else match (a,b) with
| `Split (h1,x1, p1,i1,n1), `Split (h2,x2, p2,i2,n2) -> | Split (h1,x1, p1,i1,n1), Split (h2,x2, p2,i2,n2) ->
if h1 < h2 then -1 else if h1 > h2 then 1 if h1 < h2 then -1 else if h1 > h2 then 1
else let c = X.compare x1 x2 in if c <> 0 then c else let c = X.compare x1 x2 in if c <> 0 then c
else let c = compare p1 p2 in if c <> 0 then c else let c = compare p1 p2 in if c <> 0 then c
else let c = compare i1 i2 in if c <> 0 then c