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

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 \
misc/custom.cmo types/var.cmi
types/var.cmx : misc/utils.cmx types/sortedList.cmx types/ident.cmx \
misc/custom.cmx types/var.cmi
types/boolVar.cmo : types/var.cmi misc/custom.cmo types/boolVar.cmi
types/boolVar.cmx : types/var.cmx misc/custom.cmx types/boolVar.cmi
types/boolVar.cmo : types/var.cmi misc/custom.cmo misc/bool.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/sortedList.cmi misc/pretty.cmi misc/ns.cmi types/normal.cmi \
types/intervals.cmi types/ident.cmo misc/encodings.cmi misc/custom.cmo \
......@@ -367,12 +369,13 @@ misc/html.cmi :
types/compunit.cmi :
types/sortedList.cmi : misc/custom.cmo
misc/bool.cmi : misc/custom.cmo
types/intervals.cmi : misc/custom.cmo
types/chars.cmi : misc/custom.cmo
types/atoms.cmi : misc/ns.cmi misc/encodings.cmi misc/custom.cmo
types/intervals.cmi : misc/custom.cmo misc/bool.cmi
types/chars.cmi : misc/custom.cmo misc/bool.cmi
types/atoms.cmi : misc/ns.cmi misc/encodings.cmi misc/custom.cmo \
misc/bool.cmi
types/normal.cmi :
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/ident.cmo misc/custom.cmo types/chars.cmi types/boolVar.cmi \
types/atoms.cmi
......
......@@ -8,7 +8,6 @@ sig
include Custom.T
val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
val empty : t
val full : t
......
......@@ -4,7 +4,6 @@ sig
type elem
val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
val empty : t
val full : t
......@@ -15,15 +14,10 @@ sig
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) ->
atom:(elem -> 'b) -> t -> 'b
(*
val print: string -> (Format.formatter -> elem -> unit) -> t ->
(Format.formatter -> unit) list
*)
val trivially_disjoint : t -> t -> bool
end
......
......@@ -74,7 +74,7 @@ val get_field_ascii : t -> string -> t
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 mk_ref : Types.t -> t -> t
......
......@@ -183,7 +183,7 @@ let validate_token_list s =
Value.sequence (List.map validate_token (split_xml_S s))
let validate_interval interval type_name s =
let integer =
let integer =
let s = Utf8.get_str s in
if (String.length s = 0) then simple_type_error "integer"
else
......@@ -401,7 +401,7 @@ let restrict name (base,_,_) facets cd v =
let b = (t,cd,v) in
reg name b;
b
let list name (item,_,_) cd v =
let name = add_xsd_prefix name in
let t = simple_list (Some name) item in
......@@ -410,7 +410,7 @@ let list name (item,_,_) cd v =
b
let primitive name cd v =
let primitive name cd v =
let name = add_xsd_prefix name in
let rec t =
{ st_name = Some name;
......@@ -425,37 +425,37 @@ let alias name b =
let name = add_xsd_prefix name in
reg name b
let any_simple_type =
let any_simple_type =
primitive "anySimpleType" Builtin_defs.string validate_string
let string =
primitive "string" Builtin_defs.string validate_string
let _ =
let _ =
primitive "boolean" Builtin_defs.bool validate_bool
let _ =
let _ =
primitive "hexBinary" Builtin_defs.string validate_hexBinary
let _ =
let _ =
primitive "base64Binary" Builtin_defs.string validate_base64Binary
let _ =
let _ =
primitive "anyURI" Builtin_defs.string validate_anyURI
let _ =
let _ =
primitive "duration" duration_type validate_duration
let _ =
let _ =
primitive "dateTime" dateTime_type validate_dateTime
let _ =
let _ =
primitive "time" time_type validate_time
let _ =
let _ =
primitive "date" date_type validate_date
let _ =
let _ =
primitive "gYearMonth" gYearMonth_type validate_gYearMonth
let _ =
let _ =
primitive "gYear" gYear_type validate_gYear
let _ =
let _ =
primitive "gMonthDay" gMonthDay_type validate_gMonthDay
let _ =
let _ =
primitive "gDay" gDay_type validate_gDay
let _ =
let _ =
primitive "gMonth" gMonth_type validate_gMonth
let decimal =
let decimal =
primitive "decimal" Builtin_defs.float validate_decimal
let _ =
......@@ -463,10 +463,10 @@ let _ =
alias "double" decimal
let _ =
let _ =
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
| Some min, Some max ->
let min = Intervals.V.mk min and max = Intervals.V.mk max in
......@@ -478,17 +478,17 @@ let int_type (name,min,max) =
let min = Intervals.V.mk min in
Intervals.right min
| None, None ->
Intervals.any
Intervals.full
in
ignore (primitive name (Types.interval ival) (validate_interval ival name))
let () =
List.iter int_type [
List.iter int_type [
"integer", None, None;
"nonPositiveInteger", None, Some "0";
"negativeInteger", None, Some "-1";
"long", Some "-9223372036854775808", Some "9223372036854775807";
"int", Some "-2147483648", Some "2147483647";
"int", Some "-2147483648", Some "2147483647";
"short", Some "-32768", Some "32767";
"byte", Some "-128", Some "127";
"nonNegativeInteger", Some "0", None;
......@@ -496,16 +496,16 @@ let () =
"unsignedInt", Some "0", Some "4294967295";
"unsignedShort", Some "0", Some "65535";
"unsignedByte", Some "0", Some "255";
"positiveInteger", Some "1", None
"positiveInteger", Some "1", None
]
let normalized_string =
let normalized_string =
restrict "normalizedString" string
{ no_facets with whiteSpace = `Replace, false }
Builtin_defs.string validate_normalizedString
let token =
let token =
restrict "token" normalized_string
{ no_facets with whiteSpace = `Collapse, false }
Builtin_defs.string validate_token
......@@ -695,5 +695,3 @@ let validate (_,_,v) = v
let of_st = function
| { st_name = Some n } -> get n
| _ -> assert false
......@@ -14,11 +14,11 @@ let rec iter_sep sep f = function
| [] -> ()
| [ h ] -> f h
| h :: t -> f h; sep (); iter_sep sep f t
let print_symbolset ns ppf = function
| SymbolSet.Finite l ->
iter_sep
(fun () -> Format.fprintf ppf " |@ ")
| SymbolSet.Finite l ->
iter_sep
(fun () -> Format.fprintf ppf " |@ ")
(V.print_quote ppf) l
| SymbolSet.Cofinite t ->
Format.fprintf ppf "@[`%a" Ns.InternalPrinter.print_any_ns ns;
......@@ -41,37 +41,37 @@ let single s = match get s with
| _ -> raise Exit
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))
| `Finite [ns, SymbolSet.Cofinite []] ->
| `Finite [ns, SymbolSet.Cofinite []] ->
Some (fun ppf -> Ns.InternalPrinter.print_any_ns ppf ns)
| `Cofinite [] ->
Some (fun ppf -> Format.fprintf ppf "_")
| _ -> None
let print s = match get s with
| `Finite l ->
| `Finite l ->
List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l
| `Cofinite [] ->
[ fun ppf -> Format.fprintf ppf "Atom" ]
| `Cofinite l ->
[ fun ppf ->
Format.fprintf ppf "Atom";
List.iter
(fun (ns,s) ->
List.iter
(fun (ns,s) ->
Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
l ]
type 'a map = 'a Imap.t * 'a Imap.t * 'a option
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)
(* 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)
with Not_found ->
with Not_found ->
try Imap.find mns (Upool.int (fst (V.value q)))
with Not_found -> match def with
| None -> assert false
......@@ -81,14 +81,14 @@ let mk_map l =
let all_ns = ref [] in
let all_tags = ref [] in
let def = ref None in
List.iter
List.iter
(function (s,x) ->
match get s with
| `Finite s ->
List.iter
(function
| `Finite s ->
List.iter
(function
| (_, SymbolSet.Finite t) ->
List.iter
List.iter
(fun tag -> all_tags := (Upool.int tag,x)::!all_tags) t
| (ns, _) ->
all_ns := (Upool.int ns,x)::!all_ns
......@@ -108,3 +108,9 @@ let contains_sample s t =
| None, `Finite _ -> false
| Some (_,Some tag),_ -> contains tag 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
val to_string: t -> string
end
include Custom.T
include Bool.S with type elem = V.t
val print : t -> (Format.formatter -> unit) list
type elem = V.t
val empty : t
val any : t
val full : t (* same as any *)
......
This diff is collapsed.
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
type s
type elem = s Var.var_or_atom
include Custom.T
module Atom : Bool.S
(** 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
include Bool.S with type elem = Atom.t Var.var_or_atom
val trivially_disjoint: t -> t -> bool
val var : Var.t -> t
(** vars a : return a bdd that is ( Any ^ Var a ) *)
val vars : Var.var -> t
val iter: (elem-> unit) -> t -> unit
(** returns the union of all leaves in the BDD *)
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:(elem -> 'b) -> t -> 'b
val leafconj: t -> Atom.t
val is_empty : t -> bool
......@@ -50,5 +18,4 @@ module type S = sig
end
module type MAKE = functor (T : E) -> S with type s = T.t
module Make : MAKE
module Make : functor (T : Bool.S) -> S with module Atom = T and type elem = T.t Var.var_or_atom
......@@ -40,9 +40,8 @@ val mk_ref: get:'a -> set:'a -> 'a Ident.label_map
val ref_type: Types.Node.t -> Types.t
val float: Types.t
val float_abs: Types.Abstracts.abs
val float_abs: Types.Abstracts.T.t
val any_xml : Types.t
val any_xml_with_tag: Atoms.t -> Types.t
......@@ -5,14 +5,14 @@ let max_char = 0x10FFFF
let check i = assert(i >= 0); assert(i <= max_char)
let mk_int c =
if (c < 0) || (c > max_char) then
let mk_int c =
if (c < 0) || (c > max_char) then
failwith "Chars.mk_int: code point out of bound";
c
let mk_char c =
Char.code c
let to_int c = c
let to_char c =
......@@ -34,17 +34,17 @@ let print ppf c =
Format.fprintf ppf "'%a'" print_in_string c
end
open V
include Custom.List(Custom.Pair(V)(V))
let rec check = function
| [] -> ()
| (a,b)::((c,d)::_ as tl) -> assert (a <= b); assert (b < c - 1); check tl
| [(a,b)] -> assert (a <= b)
| [(a,b)] -> assert (a <= b)
let from_int c =
if (c < 0) || (c > V.max_char) then
let from_int c =
if (c < 0) || (c > V.max_char) then
failwith "Chars.from_int: code point out of bound";
c
......@@ -62,13 +62,13 @@ let char_class a b = if a<=b then [a,b] else empty
let atom a = [a,a]
let rec add l ((a,b) as i) = match l with
| [] ->
| [] ->
[i]
| ((a1,_) :: _) as l when (b < a1 - 1) ->
| ((a1,_) :: _) as l when (b < a1 - 1) ->
i::l
| ((a1,b1) as i' :: l') when (a > b1 + 1) ->
| ((a1,b1) as i' :: l') when (a > b1 + 1) ->
i'::(add l' i)
| (a1,b1) :: l' ->
| (a1,b1) :: l' ->
add l' (min a a1, max b b1)
......@@ -118,12 +118,12 @@ let is_char = function
| _ -> None
let print =
List.map
List.map
(fun (a,b) ->
if a = b
then fun ppf ->
if a = b
then fun ppf ->
V.print ppf a
else fun ppf ->
else fun ppf ->
if a = 0 && b = max_char then Format.fprintf ppf "Char" else
Format.fprintf ppf "%a--%a" V.print a V.print b
)
......@@ -132,7 +132,7 @@ let dump ppf t =
match print t with
| [] -> Format.fprintf ppf "()"
| hd::tl -> hd ppf; List.iter (fun x -> Format.fprintf ppf "|"; x ppf) tl
type 'a map = (int * 'a) list
......@@ -144,13 +144,13 @@ let map_map f l = List.map (fun (i,x) -> (i, f x)) l
*)
let mk_map l =
let m =
List.fold_left
(fun accu (i,x) ->
let m =
List.fold_left
(fun accu (i,x) ->
List.fold_left (fun accu (a,b) -> (b,x)::accu) accu i) [] l in
let m =
List.sort
(fun (b1,x1) (b2,x2) ->
let m =
List.sort
(fun (b1,x1) (b2,x2) ->
if (b1 : int) < b2 then -1 else if b1 = b2 then 0 else 1)
m in
m
......@@ -159,3 +159,9 @@ let rec get_map c = function
| [_,x] -> x
| (b,x)::rem -> if (c : int) <= b then x else get_map c rem
| [] -> assert false
let trivially_disjoint = disjoint
let compute ~empty ~full ~cup ~cap ~diff ~atom b = assert false
let get _ = assert false
let iter _ = assert false
......@@ -9,12 +9,10 @@ module V : sig
val print_in_string : Format.formatter -> t -> unit
end
include Custom.T
include Bool.S with type elem = V.t
val print : t -> (Format.formatter -> unit) list
val dump: Format.formatter -> t -> unit
type elem = V.t
val empty : t
val any : t
val full : t (* same as any *)
......
......@@ -17,7 +17,7 @@ let check i = ()
let from_int i = big_int_of_int i
let from_bigint i = i
let mk = big_int_of_string
let to_string = string_of_big_int
let get_int = int_of_big_int
......@@ -46,7 +46,7 @@ let to_int32 i = Int32.of_string (to_string i)
let to_int64 i = Int64.of_string (to_string i)
end
type interval =
type interval =
| Bounded of big_int * big_int
| Left of big_int
| Right of big_int
......@@ -70,20 +70,20 @@ let rec compare l1 l2 =
| [],_ -> -1
| _,[] -> 1
| Bounded (a1,b1) :: l1, Bounded (a2,b2) :: l2 ->
let c = V.compare a1 a2 in if c <> 0 then c
let c = V.compare a1 a2 in if c <> 0 then c
else let c = V.compare b1 b2 in if c <> 0 then c
else compare l1 l2
| Bounded (_,_) :: _, _ -> -1
| _, Bounded (_,_) :: _ -> 1
| Left a1 :: l1, Left a2 :: l2 ->
let c = V.compare a1 a2 in if c <> 0 then c
let c = V.compare a1 a2 in if c <> 0 then c
else compare l1 l2
| Left _ :: _, _ -> -1
| _, Left _ :: _ -> 1
| Right a1 :: l1, Right a2 :: l2 ->
let c = V.compare a1 a2 in if c <> 0 then c
let c = V.compare a1 a2 in if c <> 0 then c
else compare l1 l2
| Right _ :: _, _ -> -1
| _, Right _ :: _ -> 1
......@@ -138,9 +138,9 @@ let atom a = bounded a a
let rec iadd_left l b = match l with
| [] -> [Left b]
| (Bounded (a1,_) | Right a1) :: _
when (lt_big_int b (pred_big_int a1)) ->
when (lt_big_int b (pred_big_int a1)) ->
Left b :: l
| Bounded (_,b1) :: l' ->
| Bounded (_,b1) :: l' ->
iadd_left l' (max_big_int b b1)
| Left b1 :: _ when le_big_int b b1-> l
| Left _ :: l' ->
......@@ -148,15 +148,15 @@ let rec iadd_left l b = match l with
| _ -> any
let rec iadd_bounded l a b = match l with
| [] ->
| [] ->
[Bounded (a,b)]
| (Bounded (a1,_) | Right a1) :: _
when (lt_big_int b (pred_big_int a1)) ->
when (lt_big_int b (pred_big_int a1)) ->
Bounded (a,b) :: l
| ((Bounded (_,b1) | Left b1) as i') :: l'
when (lt_big_int (succ_big_int b1) a) ->
| ((Bounded (_,b1) | Left b1) as i') :: l'
when (lt_big_int (succ_big_int b1) a) ->
i'::(iadd_bounded l' a b)
| Bounded (a1,b1) :: l' ->
| Bounded (a1,b1) :: l' ->
iadd_bounded l' (min_big_int a a1) (max_big_int b b1)
| Left b1 :: l' ->
iadd_left l' (max_big_int b b1)
......@@ -165,10 +165,10 @@ let rec iadd_bounded l a b = match l with
let rec iadd_right l a = match l with
| [] -> [Right a]
| ((Bounded (_,b1) | Left b1) as i') :: l'
when (lt_big_int (succ_big_int b1) a) ->
| ((Bounded (_,b1) | Left b1) as i') :: l'
when (lt_big_int (succ_big_int b1) a) ->
i'::(iadd_right l' a)
| (Bounded (a1,_) | Right a1) :: _ ->
| (Bounded (a1,_) | Right a1) :: _ ->
[Right (min_big_int a a1)]
| _ -> any
......@@ -180,7 +180,7 @@ let iadd l = function
let rec neg' start l = match l with
| [] -> [Right start]
| Bounded (a,b) :: l' ->
| Bounded (a,b) :: l' ->
Bounded (start, pred_big_int a) :: (neg' (succ_big_int b) l')
| Right a :: l' ->
[Bounded (start, pred_big_int a)]
......@@ -237,29 +237,29 @@ let sample = function
| (Left x | Right x | Bounded (x,_)) :: _ -> x
| Any :: _ -> zero_big_int
| [] -> raise Not_found
let single = function
| [ Bounded (x,y) ] when eq_big_int x y -> x
| [] -> raise Not_found
| _ -> raise Exit
let print =
List.map
List.map
(fun x ppf -> match x with
| Any ->
Format.fprintf ppf "Int"
| Left b ->
Format.fprintf ppf "*--%s"
| Left b ->
Format.fprintf ppf "*--%s"
(string_of_big_int b)
| Right a ->
Format.fprintf ppf "%s--*"
| Right a ->
Format.fprintf ppf "%s--*"
(string_of_big_int a)
| Bounded (a,b) when eq_big_int a b ->
Format.fprintf ppf "%s"
| Bounded (a,b) when eq_big_int a b ->
Format.fprintf ppf "%s"
(string_of_big_int a)
| Bounded (a,b) ->
Format.fprintf ppf "%s--%s"
(string_of_big_int a)
Format.fprintf ppf "%s--%s"
(string_of_big_int a)
(string_of_big_int b)
)
......@@ -268,13 +268,13 @@ let ( + ) = add_big_int
let ( * ) = mult_big_int
let add_inter i1 i2 =
let add_inter i1 i2 =
match (i1,i2) with
| Bounded (a1,b1), Bounded (a2,b2) -> Bounded (a1+a2, b1+b2)
| Bounded (_,b1), Left b2
| Bounded (_,b1), Left b2
| Left b1, Bounded (_,b2)
| Left b1, Left b2 -> Left (b1+b2)
| Bounded (a1,_), Right a2
| Bounded (a1,_), Right a2
| Right a1, Bounded (a2,_)
| Right a1, Right a2 -> Right (a1+a2)
| _ -> Any
......@@ -282,16 +282,16 @@ let add_inter i1 i2 =
(* Optimize this ... *)
let add l1 l2 =
List.fold_left
List.fold_left
(fun accu i1 ->
List.fold_left
(fun accu i2 -> iadd accu (add_inter i1 i2))
accu l2
) empty l1
let negat =
List.rev_map
let negat =
List.rev_map
(function
| Bounded (i,j) -> Bounded (minus_big_int j, minus_big_int i)
| Left i -> Right (minus_big_int i)
......@@ -304,7 +304,7 @@ let sub l1 l2 =
type i = PlusInf | MinusInf | Int of V.t
let ( * ) x y =
let ( * ) x y =
match (x,y) with
| PlusInf,PlusInf | MinusInf,MinusInf -> PlusInf
| PlusInf,MinusInf | MinusInf,PlusInf -> MinusInf
......@@ -349,12 +349,12 @@ let mul_inter i1 i2 =
vali (min4 a b c d, max4 a b c d)
let mul l1 l2 =
List.fold_left
List.fold_left
(fun accu i1 ->
List.fold_left
(fun accu i2 -> iadd accu (mul_inter i1 i2))
accu l2
) empty l1
......@@ -364,7 +364,7 @@ let modulo i1 i2 = any
let dmp s i =
let ppf = Format.std_formatter in
Format.fprintf ppf "%s = [ " s;
List.iter (fun x -> x ppf; Format.fprintf ppf " ") (print i);
List.iter (fun x -> x ppf; Format.fprintf ppf " ") (print i);
Format.fprintf ppf "] "
(*
......@@ -372,8 +372,8 @@ let diff i1 i2 =
let ppf = Format.std_formatter in
Format.fprintf ppf "Intervals.diff:";
dump "i1" i1;
dump "i2" i2;
dump "i1-i2" (diff i1 i2);
dump "i2" i2;
dump "i1-i2" (diff i1 i2);
Format.fprintf ppf "@\n";
diff i1 i2
*)
......@@ -382,8 +382,8 @@ let cap i1 i2 =
let ppf = Format.std_formatter in
Format.fprintf ppf "Intervals.cap:";
dmp "i1" i1;
dmp "i2" i2;
dmp "i1*i2" (cap i1 i2);