| _ -> false
end
-module WH = Weak.Make(Node)
-
+module WH =Weak.Make(Node)
+(* struct
+ include Hashtbl.Make(Node)
+ let merge h v =
+ if mem h v then v
+ else (add h v v;v)
+end
+*)
let pool = WH.create 4093
(* Neat trick thanks to Alain Frisch ! *)
let _ = WH.add pool empty
-let is_empty = function { id = 0 } -> true | _ -> false
+let is_empty s = s.id==0
let rec norm n =
let v = { id = gen_uid ();
(* WH.merge pool *)
-let branch (p,m,l,r) = norm (Branch(p,m,l,r))
+let branch p m l r = norm (Branch(p,m,l,r))
let leaf k = norm (Leaf k)
(* To enforce the invariant that a branch contains two non empty sub-trees *)
let branch_ne = function
| (_,_,e,t) when is_empty e -> t
| (_,_,t,e) when is_empty e -> t
- | (p,m,t0,t1) -> branch (p,m,t0,t1)
+ | (p,m,t0,t1) -> branch p m t0 t1
(********** from here on, only use the smart constructors *************)
let zero_bit k m = (k land m) == 0
-let singleton k = if k < 0 then failwith "singleton" else leaf k
+let singleton k = leaf k
let rec mem k n = match n.node with
| Empty -> false
let hbit = Array.init 256 naive_highest_bit
let highest_bit_32 x =
- let n = x lsr 24 in if n != 0 then hbit.(n) lsl 24
- else let n = x lsr 16 in if n != 0 then hbit.(n) lsl 16
- else let n = x lsr 8 in if n != 0 then hbit.(n) lsl 8
- else hbit.(x)
+ let n = x lsr 24 in if n != 0 then Array.unsafe_get hbit n lsl 24
+ else let n = x lsr 16 in if n != 0 then Array.unsafe_get hbit n lsl 16
+ else let n = x lsr 8 in if n != 0 then Array.unsafe_get hbit n lsl 8
+ else Array.unsafe_get hbit x
let highest_bit_64 x =
let n = x lsr 32 in if n != 0 then (highest_bit_32 n) lsl 32
let branching_bit p0 p1 = highest_bit (p0 lxor p1)
- let join (p0,t0,p1,t1) =
+ let join p0 t0 p1 t1 =
let m = branching_bit p0 p1 in
if zero_bit p0 m then
- branch (mask p0 m, m, t0, t1)
+ branch (mask p0 m) m t0 t1
else
- branch (mask p0 m, m, t1, t0)
+ branch (mask p0 m) m t1 t0
let match_prefix k p m = (mask k m) == p
let add k t =
let rec ins n = match n.node with
| Empty -> leaf k
- | Leaf j -> if j == k then n else join (k, leaf k, j, n)
+ | Leaf j -> if j == k then n else join k (leaf k) j n
| Branch (p,m,t0,t1) ->
if match_prefix k p m then
if zero_bit k m then
- branch (p, m, ins t0, t1)
+ branch p m (ins t0) t1
else
- branch (p, m, t0, ins t1)
+ branch p m t0 (ins t1)
else
- join (k, leaf k, p, n)
+ join k (leaf k) p n
in
ins t
(* should run in O(1) thanks to Hash consing *)
- let equal = (=)
+ let equal a b = a==b || a.id == b.id
- let compare = compare
+ let compare a b = if a == b then 0 else a.id - b.id
- let rec merge (s,t) =
+ let rec merge s t =
if (equal s t) (* This is cheap thanks to hash-consing *)
then s
else
| _, Leaf k -> add k s
| Branch (p,m,s0,s1), Branch (q,n,t0,t1) ->
if m == n && match_prefix q p m then
- branch (p, m, merge (s0,t0), merge (s1,t1))
+ branch p m (merge s0 t0) (merge s1 t1)
else if m > n && match_prefix q p m then
if zero_bit q m then
- branch (p, m, merge (s0,t), s1)
+ branch p m (merge s0 t) s1
else
- branch (p, m, s0, merge (s1,t))
- else if m < n && match_prefix p q n then
-
+ branch p m s0 (merge s1 t)
+ else if m < n && match_prefix p q n then
if zero_bit p n then
- branch (q, n, merge (s,t0), t1)
+ branch q n (merge s t0) t1
else
- branch (q, n, t0, merge (s,t1))
+ branch q n t0 (merge s t1)
else
(* The prefixes disagree. *)
- join (p, s, q, t)
+ join p s q t
- let union s t = merge (s,t)
+
let rec subset s1 s2 = (equal s1 s2) ||
match (s1.node,s2.node) with
subset l1 r2 && subset r1 r2
else
false
+
+ let union s t =
+ merge s t
let rec inter s1 s2 =
- if (equal s1 s2)
+ if equal s1 s2
then s1
else
match (s1.node,s2.node) with
| _, Leaf k2 -> if mem k2 s1 then s2 else empty
| Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
if m1 == m2 && p1 == p2 then
- merge (inter l1 l2, inter r1 r2)
+ merge (inter l1 l2) (inter r1 r2)
else if m1 > m2 && match_prefix p2 p1 m1 then
inter (if zero_bit p2 m1 then l1 else r1) s2
else if m1 < m2 && match_prefix p1 p2 m2 then
empty
let rec diff s1 s2 =
- if (equal s1 s2)
+ if equal s1 s2
then empty
else
match (s1.node,s2.node) with
| _, Leaf k2 -> remove k2 s1
| Branch (p1,m1,l1,r1), Branch (p2,m2,l2,r2) ->
if m1 == m2 && p1 == p2 then
- merge (diff l1 l2, diff r1 r2)
+ merge (diff l1 l2) (diff r1 r2)
else if m1 > m2 && match_prefix p2 p1 m1 then
if zero_bit p2 m1 then
- merge (diff l1 s2, r1)
+ merge (diff l1 s2) r1
else
- merge (l1, diff r1 s2)
+ merge l1 (diff r1 s2)
else if m1 < m2 && match_prefix p1 p2 m2 then
if zero_bit p1 m2 then diff s1 l2 else diff s1 r2
else