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.

depend

@@ -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

misc/bool.ml

@@ -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

misc/bool.mli

@@ -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
 

runtime/value.mli

@@ -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

schema/schema_builtin.ml

@@ -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
-
-

types/atoms.ml

@@ -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

types/atoms.mli

@@ -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 *)

types/boolVar.ml

@@ -2,51 +2,17 @@ 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
 
-  type 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
+  module Atom : Bool.S
 
-  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 vars  : Var.var -> t
+  val var : Var.t -> t
 
-  val iter: (elem -> unit) -> t -> unit
-
-  val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-    -> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
-    atom:(elem -> 'b) -> t -> 'b
+  (** returns the union of all leaves in the BDD *)
+  val leafconj: t -> Atom.t
 
   val is_empty : t -> bool
 
@@ -54,13 +20,8 @@ module type S = sig
 
   val print : ?f:(Format.formatter -> elem -> unit) -> t -> (Format.formatter -> unit) list
 
-(*
-  val extractvars : t -> [> `Var of Var.t ] bdd * t
-*)
 end
 
-module type MAKE = functor (T : E) -> S with type s = T.t
-
 (* ternary BDD
  * where the nodes are Atm of X.t | Var of String.t
  * Variables are always before Values
@@ -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 *)
   (* plus variables *)
   (* `Atm are containers (Atoms, Chars, Intervals, Pairs ... )
    * `Var are String
    *)
 
-  type s = T.t
-  type elem = s Var.var_or_atom
+  module Atom = T
+  type elem = T.t Var.var_or_atom
   module X : Custom.T with type t = elem = Var.Make(T)
-  type 'a bdd =
-    [ `True
-    | `False
-    | `Split of int * 'a * ('a bdd) * ('a bdd) * ('a bdd) ]
+  type 'a bdd = False
+               | True
+               | Split of int * 'a * ('a bdd) * ('a bdd) * ('a bdd)
+
   type t = elem bdd
 
   let rec equal_aux eq a b =
     (a == b) ||
     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) &&
 	  (equal_aux eq p1 p2) && (equal_aux eq i1 i2) &&
 	  (equal_aux eq n1 n2) && (eq x1 x2)
@@ -112,55 +73,55 @@ module Make (T : E) : S with type s = T.t = struct
   let rec compare a b =
     if (a == b) then 0
     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
 	  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 i1 i2 in if c <> 0 then c
 	  else compare n1 n2
-      | `True,_  -> -1
-      | _, `True -> 1
-      | `False,_ -> -1
-      | _,`False -> 1
+      | True,_  -> -1
+      | _, True -> 1
+      | False,_ -> -1
+      | _,False -> 1
 
   let rec hash = function
-    | `True -> 1
-    | `False -> 0
-    | `Split(h,_,_,_,_) -> h
+    | True -> 1
+    | False -> 0
+    | Split(h,_,_,_,_) -> h
 
   let compute_hash x p i n =
 	(X.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
 
   let rec check = function
-    | `True -> ()
-    | `False -> ()
-    | `Split (h,x,p,i,n) ->
+    | True -> ()
+    | False -> ()
+    | Split (h,x,p,i,n) ->
 	assert (h = compute_hash x p i n);
-	(match p with `Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
-	(match i with `Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
-	(match n with `Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
+	(match p with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
+	(match i with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
+	(match n with Split (_,y,_,_,_) -> assert (X.compare x y < 0) | _ -> ());
 	X.check x; check p; check i; check n
 
   let atom x =
     let h = X.hash x + 17 in (* partial evaluation of compute_hash... *)
-    `Split (h, x,`True,`False,`False)
+    Split (h, x,True,False,False)
 
-  let vars v =
+  let var v =
     let compute_hash x p i n =
         (Var.hash x) + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
     in
     let a = atom (`Atm T.full) in
-    let h = compute_hash v a `False `False in
-    ( `Split (h,`Var v,a,`False,`False) :> t )
+    let h = compute_hash v a False False in
+    ( Split (h,`Var v,a,False,False) :> t )
 
   let rec iter f = function
-    | `Split (_, x, p,i,n) -> f x; iter f p; iter f i; iter f n
+    | Split (_, x, p,i,n) -> f x; iter f p; iter f i; iter f n
     | _ -> ()
 
   let rec dump ppf = function
-    | `True -> Format.fprintf ppf "⫧"
-    | `False -> Format.fprintf ppf "⫨"
-    | `Split (_,x, p,i,n) ->
+    | True -> Format.fprintf ppf "⫧"
+    | False -> Format.fprintf ppf "⫨"
+    | Split (_,x, p,i,n) ->
       let fmt = format_of_string (
         match x with
           `Var _ ->
@@ -173,51 +134,52 @@ module Make (T : E) : S with type s = T.t = struct
         X.dump x dump p dump i dump n
 
   let rec print f ppf = function
-    | `True -> Format.fprintf ppf "Any"
-    | `False -> Format.fprintf ppf "Empty"
-    | `Split (_, x, p,i, n) ->
+    | True -> Format.fprintf ppf "Any"
+    | False -> Format.fprintf ppf "Empty"
+    | Split (_, x, p,i, n) ->
 	let flag = ref false in
 	let b () = if !flag then Format.fprintf ppf " | " else flag := true in
 	(match p with
-	   | `True -> b(); Format.fprintf ppf "%a" f x
-	   | `False -> ()
+	   | True -> b(); Format.fprintf ppf "%a" f x
+	   | False -> ()
 	   | _ -> b (); Format.fprintf ppf "%a & @[(%a)@]" f x (print f) p );
 	(match i with
-	   | `True -> assert false;
-	   | `False -> ()
+	   | True -> assert false;
+	   | False -> ()
 	   | _ -> b(); print f ppf i);
 	(match n with
-	   | `True -> b (); Format.fprintf ppf "@[~%a@]" f x
-	   | `False -> ()
+	   | True -> b (); Format.fprintf ppf "@[~%a@]" f x
+	   | False -> ()
 	   | _ -> b (); Format.fprintf ppf "@[~%a@] & @[(%a)@]" f x (print f) n)
 
   let pp_print = print X.dump
 
   let print ?(f=X.dump) = function
-    | `True -> assert false (* [] a bdd cannot be of this type *)
-    | `False -> [ fun ppf -> Format.fprintf ppf "Empty" ]
+    | True -> assert false (* [] a bdd cannot be of this type *)
+    | False -> [ fun ppf -> Format.fprintf ppf "Empty" ]
     | c -> [ fun ppf -> print f ppf c ]
 
   (* return a list of pairs, where each pair holds the list
    * of positive and negative elements on a branch *)
   let get x =
     let rec aux accu pos neg = function
-      | `True -> (List.rev pos, List.rev neg) :: accu
-      | `False -> accu
-      | `Split (_,x, p,i,n) ->
+      | True -> (List.rev pos, List.rev neg) :: accu
+      | False -> accu
+      | Split (_,x, p,i,n) ->
         let accu = aux accu (x::pos) neg p in
         let accu = aux accu pos (x::neg) n in
         let accu = aux accu pos neg i in
         accu
     in aux [] [] [] x
 
+
   let leafconj x =
     let rec aux accu = function
-      | `True -> accu
-      | `False -> accu
-      | `Split (_,`Atm x, `True,`False,`False) -> x :: accu
-      | `Split (_,`Atm x, _,_,_) -> assert false
-      | `Split (_,`Var x, p,i,n) ->
+      | True -> accu
+      | False -> accu
+      | Split (_,`Atm x, True,False,False) -> x :: accu
+      | Split (_,`Atm x, _,_,_) -> assert false
+      | Split (_,`Var x, p,i,n) ->
         let accu = aux accu p in
         let accu = aux accu n in
         let accu = aux accu i in
@@ -227,11 +189,11 @@ module Make (T : E) : S with type s = T.t = struct
 
   let compute ~empty ~full ~cup ~cap ~diff ~atom b =
     let rec aux = function
-      | `True  -> full
-      | `False -> empty
-      | `Split (_,`Atm x,`True,_,_) when T.equal x T.empty -> empty
-      | `Split (_,`Atm x,`True,_,_) when T.equal x T.full -> full
-      | `Split(_,x, p,i,n) ->
+      | True  -> full
+      | False -> empty
+      | Split (_,`Atm x,True,_,_) when T.equal x T.empty -> empty
+      | Split (_,`Atm x,True,_,_) when T.equal x T.full -> full
+      | Split(_,x, p,i,n) ->
         let x1 = atom x in
 	let p = cap x1 (aux p) in
         let i = aux i in
@@ -243,21 +205,20 @@ module Make (T : E) : S with type s = T.t = struct
 (* Invariant: correct hash value *)
 
   let split0 x pos ign neg =
-    `Split (compute_hash x pos ign neg, x, pos, ign, neg)
+    Split (compute_hash x pos ign neg, x, pos, ign, neg)
 
-  let empty = `False
-  let full = split0 (`Atm T.full) `True `False `False
-  let any = full
+  let empty = False
+  let full = split0 (`Atm T.full) True False False
 
   let is_empty t = (t == empty)