Commits

jhwoodyatt  committed 0a85c0a

Fixed error in [member] that could produce false negatives. Improved
performance of some set operations. Wrote a note to myself about more
opportunities for performance enhancement.

  • Participants
  • Parent commits 87572b2

Comments (0)

Files changed (1)

File cf/cf_rbtree.ml

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-type 'a node_t =
-    | R of 'a * 'a node_t * 'a node_t
-    | B of 'a * 'a node_t * 'a node_t
+type 'a node =
+    | R of 'a * 'a node * 'a node
+    | B of 'a * 'a node * 'a node
     | Z
 
 module type Node_T = sig
     module N = N
 
     (*
-    type 'a ic_t = IC_o | IC_l of 'a N.t | IC_r of 'a N.t
+    type 'a ic = IC_o | IC_l of 'a N.t | IC_r of 'a N.t
     
     let invariant_key_compare_ x = function
         | IC_o ->
             failwith "key out of order"
     
     let invariant_print_aux_ =
-        let rec loop (ic : 'a ic_t) = function
+        let rec loop (ic : 'a ic) = function
             | Z ->
                 Format.printf "Z@\n";
                 0
                 end
         in
         fun u ->
-            try ignore (loop u); true with Failure _ as x -> false
-
+            try ignore (loop u); true with Failure _ -> false
             (* ignore (loop u); true *)
             (* try ignore (loop u); true with Failure _ as x -> false *)
     
         | R (_, a, b)
         | B (_, a, b) ->
             succ (size a + size b)
-
-    let rec min_aux_ = function
+    
+    let rec min = function
         | Z ->
             raise Not_found
-        | (R (_, Z, _) as x)
-        | (B (_, Z, _) as x) ->
+        | R (x, Z, _)
+        | B (x, Z, _) ->
             x
         | R (_, y, _)
         | B (_, y, _) ->
-            min_aux_ y
-
-    let rec max_aux_ = function
+            min y
+            
+    let rec max = function
         | Z ->
             raise Not_found
-        | (R (_, _, Z) as x)
-        | (B (_, _, Z) as x) ->
+        | R (x, _, Z)
+        | B (x, _, Z) ->
             x
         | R (_, _, y)
         | B (_, _, y) ->
-            max_aux_ y
-            
-    let min u =
-        match min_aux_ u with
-        | Z ->
-            assert (not true);
-            raise Not_found
-        | R (n, _, _)
-        | B (n, _, _) ->
-            n
-            
-    let max u =
-        match max_aux_ u with
-        | Z ->
-            assert (not true);
-            raise Not_found
-        | R (n, _, _)
-        | B (n, _, _) ->
-            n
-
-    type 'a znode_t = Z0 | N0 of 'a * 'a znode_t * 'a znode_t
+            max y
     
     let rec search key = function
         | Z ->
             false
         | (R (n, a, b) | B (n, a, b)) ->
             let d = N.kcompare key n in
-            d = 0 || member key (if d < 0 then a else b)
+            if d = 0 then true else member key (if d < 0 then a else b)
 
     let l_balance_ z n1 n2 =
         match n1, n2 with
                 let n, r = r_repair_ n in n, m, r
             else
                 n, m, false
+
+    let cons_r_ x a b = R (x, a, b)
+    let cons_b_ x a b = B (x, a, b)
+    
+    let ifxz_r_ y a = a, false, y
+
+    let ifxz_b_ y = function
+        | R (z, a, b) -> B (z, a, b), false, y
+        | u -> u, true, y
     
     let rec extract_aux_ k = function
-        | Z ->
-            raise Not_found
-        | B (y, a, b) ->
-            let d = N.kcompare k y in
-            if d < 0 then begin
-                let a, r, v = extract_aux_ k a in
-                let n = B (y, a, b) in
-                let n, r = if r then r_repair_ n else n, false in
-                n, r, v
-            end
-            else if d > 0 then begin
-                let b, r, v = extract_aux_ k b in
-                let n = B (y, a, b) in
-                let n, r = if r then l_repair_ n else n, false in
-                n, r, v
-            end
-            else if b = Z then begin
-                match a with
-                | R (z, a, b) -> B (z, a, b), false, y
-                | u -> u, true, y
-            end
-            else begin
-                let b, z, d = extract_min_ b in
-                let n = B (z, a, b) in
-                let n, r = if d then l_repair_ n else n, false in
-                n, r, y
-            end
-        | R (y, a, b) ->
-            let d = N.kcompare k y in
-            if d < 0 then begin
-                let a, r, v = extract_aux_ k a in
-                let n = R (y, a, b) in
-                let n, r = if r then r_repair_ n else n, false in
-                n, r, v
-            end
-            else if d > 0 then begin
-                let b, r, v = extract_aux_ k b in
-                let n = R (y, a, b) in
-                let n, r = if r then l_repair_ n else n, false in
-                n, r, v
-            end
-            else if b = Z then begin
-                a, false, y
-            end
-            else begin
-                let b, z, d = extract_min_ b in
-                let n = R (z, a, b) in
-                let n, r = if d then l_repair_ n else n, false in
-                n, r, y
-            end
+        | Z -> raise Not_found
+        | B (y, a, b) -> extract_aux_mirror_ cons_b_ ifxz_b_ k y a b
+        | R (y, a, b) -> extract_aux_mirror_ cons_r_ ifxz_r_ k y a b
+
+    and extract_aux_mirror_ cons ifxz k y a b =
+        let d = N.kcompare k y in
+        if d < 0 then begin
+            let a, r, v = extract_aux_ k a in
+            let n = cons y a b in
+            let n, r = if r then r_repair_ n else n, false in
+            n, r, v
+        end
+        else if d > 0 then begin
+            let b, r, v = extract_aux_ k b in
+            let n = cons y a b in
+            let n, r = if r then l_repair_ n else n, false in
+            n, r, v
+        end
+        else if b = Z then begin
+            ifxz y a
+        end
+        else begin
+            let b, z, d = extract_min_ b in
+            let n = cons z a b in
+            let n, r = if d then l_repair_ n else n, false in
+            n, r, y
+        end
     
+    let ifdz_r_ a = a, false
+    let ifdz_b_ = function R (z, a, b) -> B (z, a, b), false | u -> u, true
+    
+    let rec delete_aux_ k = function
+        | Z -> raise Not_found
+        | B (y, a, b) -> delete_aux_mirror_ cons_b_ ifdz_b_ k y a b
+        | R (y, a, b) -> delete_aux_mirror_ cons_r_ ifdz_r_ k y a b
+
+    and delete_aux_mirror_ cons ifdz k y a b =
+        let d = N.kcompare k y in
+        if d < 0 then begin
+            let a, r = delete_aux_ k a in
+            let n = cons y a b in
+            if r then r_repair_ n else n, false
+        end
+        else if d > 0 then begin
+            let b, r = delete_aux_ k b in
+            let n = cons y a b in
+            if r then l_repair_ n else n, false
+        end
+        else if b = Z then begin
+            ifdz a
+        end
+        else begin
+            let b, z, d = extract_min_ b in
+            let n = cons z a b in
+            if d then l_repair_ n else n, false
+        end
+
     let delete k u =
         try
-            let u, _, _ = extract_aux_ k u in
+            let u, _ = delete_aux_ k u in
             (* assert (invariant_aux_ u); *)
             u
         with
     
     let of_seq z = of_seq_aux_ nil z
     
-    type 'a digit_t =
-        | Y of 'a node_t * 'a
-        | X of 'a node_t * 'a * 'a node_t * 'a
+    type 'a digit =
+        | Y of 'a node * 'a
+        | X of 'a node * 'a * 'a node * 'a
 
     let rec accum_incr_ n x = function
         | [] -> [ Y (n, x) ]
             | Cf_seq.Z -> Z
             | Cf_seq.P (hd, tl) -> loop hd [ Y (Z, hd) ] tl
     
-    type 'a stack_t = ('a * 'a node_t) list
+    type 'a stack = ('a * 'a node) list
     
     let rec stack_min_ i = function
         | Z ->
     end)
     
     module Element = E
-    type t = E.t node_t
+    type t = E.t node
         
     let put = replace
     let clear = delete
     let clear_swap_ s x = delete x s
     let member_swap_ s x = member x s
     
+    (*---
+      The [diff], [intersect] and [union] functions may be more efficient
+      if implemented more like the functions in the standard OCaml library
+      [Set] module.  The key function there is [join], which would have to be
+      rewritten for red-black trees.  The [split] and [concat] functions are
+      implemented on top of [join].  The [diff], [intersect] and [union]
+      functions are implemented on top of [join], [split] and [concat].  If
+      [join] is fast enough on RB-trees, then our efficiency should compare
+      well with the standard library.
+      
+      Hint: implement [join_aux_ ltree lheight v rheight rtree] and assume that
+      [lheight] is the black-height of the [ltree] node and [rheight] is the
+      black-height of the [rtree] node; then implement [join] as a wrapper on
+      [join_aux_] that first computes the black-hight of [ltree] and [rtree].
+      ---*)
+    
     let union s0 s1 = fold put_swap_ s0 s1
     let diff s0 s1 = fold clear_swap_ s0 s1
     let intersect s0 s1 = filter (member_swap_ s0) s1    
-    let subset s0 s1 = predicate (member_swap_ s0) s1
-
-    (*
-    this code was an aborted attempt at improving performance.  it didn't seem
-    to work, but that *may* have been the benchmark i was using, so i'm not in
-    a big hurry to delete it just yet.  <jhw@conjury.org>
-    
-    let rec log2_aux_ v n = if n > 1 then log2_aux_ (v + 1) (n lsr 1) else v
-    let log2_ n = log2_aux_ 0 n
-
-    let paint_black_ = function
-        | R (x, a, b) -> B (x, a, b)
-        | u -> u
 
     let rec subset s1 s2 =
         match s1, s2 with
             else
                 subset (B (x1, Z, b1)) b2 && subset a1 s2
 
+    (*
+    this code was an aborted attempt at improving performance.  it didn't seem
+    to work, but that *may* have been the benchmark i was using, so i'm not in
+    a big hurry to delete it just yet.  <jhw@conjury.org>
+    (**)
+    
+    let rec log2_aux_ v n = if n > 1 then log2_aux_ (v + 1) (n lsr 1) else v
+    let log2_ n = log2_aux_ 0 n
+
+    let paint_black_ = function
+        | R (x, a, b) -> B (x, a, b)
+        | u -> u
+    
     let rec height_ acc = function
         | Z -> acc
         | R (_, a, _) -> height_ acc a
         | Cf_seq.P (x, z) when n = 1 ->
             1, B (x, Z, Z), z
         | _ ->
-            let d = (1 lsl n) - 1 in
             let n = pred n in
             let ah, a, z = build_dn_ n z in
             match Lazy.force z with
 
     module Key = K
     
-    type 'a t = 'a N.t node_t
+    type 'a t = 'a N.t node
     
     let search key u = N.obj (search key u)
-    
+        
     let extract k u =
         let u, _, v = extract_aux_ k u in
         (* assert (invariant_aux_ u); *)