INCLUDE "utils.ml"
module type S =
sig
- include Set.S
- type data
+ type elt
+
+ type 'a node
+ module rec Node : sig
+ include Hcons.S with type data = Data.t
+ end
+ and Data : sig
+ include
+ Hashtbl.HashedType with type t = Node.t node
+ end
+ type data = Data.t
+ type t = Node.t
+
+
+ val empty : t
+ val is_empty : t -> bool
+ val mem : elt -> t -> bool
+ val add : elt -> t -> t
+ val singleton : elt -> t
+ val remove : elt -> t -> t
+ val union : t -> t -> t
+ val inter : t -> t -> t
+ val diff : t -> t -> t
+ val compare : t -> t -> int
+ val equal : t -> t -> bool
+ val subset : t -> t -> bool
+ val iter : (elt -> unit) -> t -> unit
+ val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+ val for_all : (elt -> bool) -> t -> bool
+ val exists : (elt -> bool) -> t -> bool
+ val filter : (elt -> bool) -> t -> t
+ val partition : (elt -> bool) -> t -> t * t
+ val cardinal : t -> int
+ val elements : t -> elt list
+ val min_elt : t -> elt
+ val max_elt : t -> elt
+ val choose : t -> elt
+ val split : elt -> t -> t * bool * t
+
val intersect : t -> t -> bool
val is_singleton : t -> bool
val mem_union : t -> t -> t
val hash : t -> int
- val uid : t -> int
+ val uid : t -> Uid.t
val uncons : t -> elt*t
val from_list : elt list -> t
val make : data -> t
val node : t -> data
+
+ val with_id : Uid.t -> t
end
-module Make ( H : Hcons.S ) : S with type elt = H.t =
+module Make ( H : Hcons.SA ) : S with type elt = H.t =
struct
type elt = H.t
type 'a node =
| Leaf of elt
| Branch of int * int * 'a * 'a
- module rec HNode : Hcons.S with type data = Node.t = Hcons.Make (Node)
- and Node : Hashtbl.HashedType with type t = HNode.t node =
+ module rec Node : Hcons.S with type data = Data.t = Hcons.Make (Data)
+ and Data : Hashtbl.HashedType with type t = Node.t node =
struct
- type t = HNode.t node
+ type t = Node.t node
let equal x y =
match x,y with
| Empty,Empty -> true
- | Leaf k1, Leaf k2 -> H.equal k1 k2
+ | Leaf k1, Leaf k2 -> k1 == k2
| Branch(b1,i1,l1,r1),Branch(b2,i2,l2,r2) ->
b1 == b2 && i1 == i2 &&
- (HNode.equal l1 l2) &&
- (HNode.equal r1 r2)
+ (Node.equal l1 l2) &&
+ (Node.equal r1 r2)
| _ -> false
let hash = function
| Empty -> 0
- | Leaf i -> HASHINT2(HALF_MAX_INT,H.hash i)
- | Branch (b,i,l,r) -> HASHINT4(b,i,HNode.hash l, HNode.hash r)
+ | Leaf i -> HASHINT2(HALF_MAX_INT,Uid.to_int (H.uid i))
+ | Branch (b,i,l,r) -> HASHINT4(b,i,Uid.to_int l.Node.id, Uid.to_int r.Node.id)
end
- ;;
-
- type t = HNode.t
- type data = t node
- let hash = HNode.hash
- let uid = HNode.uid
- let make = HNode.make
+
+ type data = Data.t
+ type t = Node.t
+
+ let hash = Node.hash
+ let uid = Node.uid
+ let make = Node.make
let node _ = failwith "node"
- let empty = HNode.make Empty
+ let empty = Node.make Empty
- let is_empty s = (HNode.node s) == Empty
+ let is_empty s = (Node.node s) == Empty
- let branch p m l r = HNode.make (Branch(p,m,l,r))
+ let branch p m l r = Node.make (Branch(p,m,l,r))
- let leaf k = HNode.make (Leaf k)
+ let leaf k = Node.make (Leaf k)
(* To enforce the invariant that a branch contains two non empty sub-trees *)
let branch_ne p m t0 t1 =
let singleton k = leaf k
let is_singleton n =
- match HNode.node n with Leaf _ -> true
+ match Node.node n with Leaf _ -> true
| _ -> false
let mem (k:elt) n =
- let kid = H.uid k in
- let rec loop n = match HNode.node n with
+ let kid = Uid.to_int (H.uid k) in
+ let rec loop n = match Node.node n with
| Empty -> false
- | Leaf j -> H.equal k j
+ | Leaf j -> k == j
| Branch (p, _, l, r) -> if kid <= p then loop l else loop r
in loop n
- let rec min_elt n = match HNode.node n with
+ let rec min_elt n = match Node.node n with
| Empty -> raise Not_found
| Leaf k -> k
| Branch (_,_,s,_) -> min_elt s
- let rec max_elt n = match HNode.node n with
+ let rec max_elt n = match Node.node n with
| Empty -> raise Not_found
| Leaf k -> k
| Branch (_,_,_,t) -> max_elt t
let elements s =
- let rec elements_aux acc n = match HNode.node n with
+ let rec elements_aux acc n = match Node.node n with
| Empty -> acc
| Leaf k -> k :: acc
| Branch (_,_,l,r) -> elements_aux (elements_aux acc r) l
let match_prefix k p m = (mask k m) == p
let add k t =
- let kid = H.uid k in
- let rec ins n = match HNode.node n with
+ let kid = Uid.to_int (H.uid k) in
+ let rec ins n = match Node.node n with
| Empty -> leaf k
- | Leaf j -> if H.equal j k then n else join kid (leaf k) (H.uid j) n
+ | Leaf j -> if j == k then n else join kid (leaf k) (Uid.to_int (H.uid j)) n
| Branch (p,m,t0,t1) ->
if match_prefix kid p m then
if zero_bit kid m then
ins t
let remove k t =
- let kid = H.uid k in
- let rec rmv n = match HNode.node n with
+ let kid = Uid.to_int(H.uid k) in
+ let rec rmv n = match Node.node n with
| Empty -> empty
- | Leaf j -> if H.equal k j then empty else n
+ | Leaf j -> if k == j then empty else n
| Branch (p,m,t0,t1) ->
if match_prefix kid p m then
if zero_bit kid m then
(* should run in O(1) thanks to Hash consing *)
- let equal a b = HNode.equal a b
+ let equal a b = Node.equal a b
- let compare a b = (HNode.uid a) - (HNode.uid b)
+ let compare a b = (Uid.to_int (Node.uid a)) - (Uid.to_int (Node.uid b))
let rec merge s t =
if (equal s t) (* This is cheap thanks to hash-consing *)
then s
else
- match HNode.node s, HNode.node t with
+ match Node.node s, Node.node t with
| Empty, _ -> t
| _, Empty -> s
| Leaf k, _ -> add k t
let rec subset s1 s2 = (equal s1 s2) ||
- match (HNode.node s1,HNode.node s2) with
+ match (Node.node s1,Node.node s2) with
| Empty, _ -> true
| _, Empty -> false
| Leaf k1, _ -> mem k1 s2
let equal (x,y) (z,t) = (equal x z)&&(equal y t)
let equal a b = equal a b || equal b a
let hash (x,y) = (* commutative hash *)
- let x = HNode.hash x
- and y = HNode.hash y
+ let x = Node.hash x
+ and y = Node.hash y
in
if x < y then HASHINT2(x,y) else HASHINT2(y,x)
end)
if equal s1 s2
then s1
else
- match (HNode.node s1,HNode.node s2) with
+ match (Node.node s1,Node.node s2) with
| Empty, _ -> empty
| _, Empty -> empty
| Leaf k1, _ -> if mem k1 s2 then s1 else empty
if equal s1 s2
then empty
else
- match (HNode.node s1,HNode.node s2) with
+ match (Node.node s1,Node.node s2) with
| Empty, _ -> empty
| _, Empty -> s1
| Leaf k1, _ -> if mem k1 s2 then empty else s1
[exists], [filter], [partition], [choose], [elements]) are
implemented as for any other kind of binary trees. *)
-let rec cardinal n = match HNode.node n with
+let rec cardinal n = match Node.node n with
| Empty -> 0
| Leaf _ -> 1
| Branch (_,_,t0,t1) -> cardinal t0 + cardinal t1
-let rec iter f n = match HNode.node n with
+let rec iter f n = match Node.node n with
| Empty -> ()
| Leaf k -> f k
| Branch (_,_,t0,t1) -> iter f t0; iter f t1
-let rec fold f s accu = match HNode.node s with
+let rec fold f s accu = match Node.node s with
| Empty -> accu
| Leaf k -> f k accu
| Branch (_,_,t0,t1) -> fold f t0 (fold f t1 accu)
-let rec for_all p n = match HNode.node n with
+let rec for_all p n = match Node.node n with
| Empty -> true
| Leaf k -> p k
| Branch (_,_,t0,t1) -> for_all p t0 && for_all p t1
-let rec exists p n = match HNode.node n with
+let rec exists p n = match Node.node n with
| Empty -> false
| Leaf k -> p k
| Branch (_,_,t0,t1) -> exists p t0 || exists p t1
-let rec filter pr n = match HNode.node n with
+let rec filter pr n = match Node.node n with
| Empty -> empty
| Leaf k -> if pr k then n else empty
| Branch (p,m,t0,t1) -> branch_ne p m (filter pr t0) (filter pr t1)
let partition p s =
- let rec part (t,f as acc) n = match HNode.node n with
+ let rec part (t,f as acc) n = match Node.node n with
| Empty -> acc
| Leaf k -> if p k then (add k t, f) else (t, add k f)
| Branch (_,_,t0,t1) -> part (part acc t0) t1
in
part (empty, empty) s
-let rec choose n = match HNode.node n with
+let rec choose n = match Node.node n with
| Empty -> raise Not_found
| Leaf k -> k
| Branch (_, _,t0,_) -> choose t0 (* we know that [t0] is non-empty *)
(*s Additional functions w.r.t to [Set.S]. *)
let rec intersect s1 s2 = (equal s1 s2) ||
- match (HNode.node s1,HNode.node s2) with
+ match (Node.node s1,Node.node s2) with
| Empty, _ -> false
| _, Empty -> false
| Leaf k1, _ -> mem k1 s2
-let rec uncons n = match HNode.node n with
+let rec uncons n = match Node.node n with
| Empty -> raise Not_found
| Leaf k -> (k,empty)
| Branch (p,m,s,t) -> let h,ns = uncons s in h,branch_ne p m ns t
let from_list l = List.fold_left (fun acc e -> add e acc) empty l
-
+let with_id = Node.with_id
end
-module Int : S with type elt = int
- =
- Make ( struct type t = int
- type data = t
- external hash : t -> int = "%identity"
- external uid : t -> int = "%identity"
- let equal : t -> t -> bool = (==)
- external make : t -> int = "%identity"
- external node : t -> int = "%identity"
-
- end
- )
+module Int : sig
+ include S with type elt = int
+ val print : Format.formatter -> t -> unit
+end
+ =
+struct
+ include Make ( struct type t = int
+ type data = t
+ external hash : t -> int = "%identity"
+ external uid : t -> Uid.t = "%identity"
+ external equal : t -> t -> bool = "%eq"
+ external make : t -> int = "%identity"
+ external node : t -> int = "%identity"
+ external with_id : Uid.t -> t = "%identity"
+ end
+ )
+ let print ppf s =
+ Format.pp_print_string ppf "{ ";
+ iter (fun i -> Format.fprintf ppf "%i " i) s;
+ Format.pp_print_string ppf "}";
+ Format.pp_print_flush ppf ()
+ end
projects / SXSI / xpathcomp.git / blobdiff