Merge 71ada78 into d386cc9

jscomp/others/bs_internalAVLset.ml

@@ -79,24 +79,6 @@ let bal l v r =
 
 let singleton0 x = return @@ node ~left:empty ~key:x ~right:empty ~h:1
 
-(* [addMinElement v n] and [addMaxElement v n] 
-   assume that the added v is *strictly*
-   smaller (or bigger) than all the present elements in the tree.
-   They are only used during the "join" operation which
-   respects this precondition.
-*)
-
-let rec addMinElement v n =
-  match toOpt n with 
-  | None -> singleton0 v
-  | Some n  ->
-    bal (addMinElement v (left n))  (key n) (right n)
-
-let rec addMaxElement v n = 
-  match toOpt n with 
-  | None -> singleton0 v
-  | Some n  ->
-    bal (left n) (key n) (addMaxElement v (right n))
 
 let rec min0Aux n = 
   match toOpt (left n) with 
@@ -182,14 +164,33 @@ let rec exists0 n p =
     exists0 (right n) p 
 
 
+(* [addMinElement v n] and [addMaxElement v n] 
+   assume that the added v is *strictly*
+   smaller (or bigger) than all the present elements in the tree.
+   They are only used during the "join" operation which
+   respects this precondition.
+*)
+
+let rec addMinElement n v =
+  match toOpt n with 
+  | None -> singleton0 v
+  | Some n  ->
+    bal (addMinElement (left n) v)  (key n) (right n)
+
+let rec addMaxElement n v = 
+  match toOpt n with 
+  | None -> singleton0 v
+  | Some n  ->
+    bal (left n) (key n) (addMaxElement (right n) v)
+
 (* [join ln v rn] return a balanced tree simliar to [create ln v rn]
    bal, but no assumptions are made on the
    relative heights of [ln] and [rn]. *)
 
 let rec join ln v rn =
   match (toOpt ln, toOpt rn) with
-    (None, _) -> addMinElement v rn 
-  | (_, None) -> addMaxElement v ln 
+    (None, _) -> addMinElement rn v 
+  | (_, None) -> addMaxElement ln v
   | Some l, Some r ->   
     let lh = h l in     
     let rh = h r in 
@@ -218,8 +219,15 @@ let rec filter0 n p =
     let newL = filter0 l p in
     let pv = p v [@bs] in
     let newR = filter0 r p in
-    if pv then join newL v newR else concat newL newR
-
+    if pv then 
+      (if l == newL && r == newR then 
+        return n
+      else join newL v newR)
+    else concat newL newR
+(* ATT: functional methods in general can be shared with 
+    imperative methods, however, it does not apply when functional 
+    methods makes use of referential equality
+*)
 let rec partition0  n p =
   match toOpt n with 
   |  None -> (empty, empty)
@@ -298,8 +306,33 @@ let toArray0 n =
     v 
 
 
+let rec ofSortedArrayAux arr off len =     
+  match len with 
+  | 0 -> empty0
+  | 1 -> singleton0 (A.unsafe_get arr off)
+  | 2 ->  
+    let x0,x1 = A.(unsafe_get arr off, unsafe_get arr (off + 1) ) 
+    in 
+    return @@ node ~left:(singleton0 x0) ~key:x1 ~h:2 ~right:empty0
+  | 3 -> 
+    let x0,x1,x2 = 
+      A.(unsafe_get arr off, 
+         unsafe_get arr (off + 1), 
+         unsafe_get arr (off + 2)) in 
+    return @@ node ~left:(singleton0 x0)
+      ~right:(singleton0 x2)
+      ~key:x1
+      ~h:2
+  | _ ->  
+    let nl = len / 2 in 
+    let left = ofSortedArrayAux arr off nl in 
+    let mid = A.unsafe_get arr (off + nl) in 
+    let right = 
+      ofSortedArrayAux arr (off + nl + 1) (len - nl - 1) in 
+    create left mid right    
 
 
+(******************************************************************)
 
 (* 
   L rotation, return root node
@@ -369,8 +402,27 @@ let balMutate nt  =
       nt
     end
 
+let rec addMinElementMutate n v = 
+  match toOpt n with 
+  | None -> singleton0 v 
+  | Some n ->     
+    let l = left n in 
+    let newL = (addMinElementMutate l v) in  
+    begin 
+      leftSet n newL;
+      return (balMutate n )
+    end
+let rec addMaxElementMutate n v = 
+  match toOpt n with 
+  | None -> singleton0 v 
+  | Some n -> 
+    rightSet n (addMaxElementMutate (right n) v);
+    return (balMutate n )    
 
-
+(* [removeMinAuxMutateWithRoot nt n]
+   remove the minimum element from n, and 
+   set such element to [nt]
+ *)    
 let rec removeMinAuxMutateWithRoot nt n = 
   let rn, ln = right n, left n in 
   match toOpt ln with 
@@ -381,31 +433,52 @@ let rec removeMinAuxMutateWithRoot nt n =
     leftSet n (removeMinAuxMutateWithRoot nt ln); 
     return (balMutate n)    
 
+let rec removeMinAuxMutateWithRef n v =    
+  let rn, ln = right n, left n in 
+  match toOpt ln with 
+  | None ->  v := key n; rn  
+  | Some ln -> 
+    leftSet n (removeMinAuxMutateWithRef ln v);
+    return (balMutate n)
+
+let rec joinMutate ln v rn =     
+  match toOpt ln, toOpt rn with 
+  | None, _ -> addMinElementMutate rn v 
+  | _, None -> addMaxElementMutate ln v
+  | Some l, Some r -> 
+    let lh, rh = h l, h r in 
+    if lh > rh + 2 then  begin 
+      rightSet l (joinMutate (right l) v rn  );
+      return @@ balMutate l 
+    end 
+    else if rh > lh + 2 then begin 
+       leftSet r (joinMutate ln v (left r));
+       return (balMutate r)
+    end 
+    else create ln v rn 
+
+let concatMutate t1 t2 = 
+  match toOpt t1, toOpt t2 with 
+  | None, _ -> t2
+  | _, None -> t1 
+  | _, Some t2n -> 
+    let v = ref (key t2n) in 
+    let t2r = removeMinAuxMutateWithRef t2n v in 
+    joinMutate t1 !v t2r 
+
+let rec filterMutate s f = 
+  match toOpt s with 
+  | None -> empty 
+  | Some n -> 
+    let l, v, r = left n, key n, right n in 
+    let newL = filterMutate l f in 
+    let pv = f v [@bs] in 
+    let newR = filterMutate r f in 
+    if pv then 
+      joinMutate newL v newR
+    else concatMutate newL newR
+
 
-let rec ofSortedArrayAux arr off len =     
-  match len with 
-  | 0 -> empty0
-  | 1 -> singleton0 (A.unsafe_get arr off)
-  | 2 ->  
-    let x0,x1 = A.(unsafe_get arr off, unsafe_get arr (off + 1) ) 
-    in 
-    return @@ node ~left:(singleton0 x0) ~key:x1 ~h:2 ~right:empty0
-  | 3 -> 
-    let x0,x1,x2 = 
-      A.(unsafe_get arr off, 
-         unsafe_get arr (off + 1), 
-         unsafe_get arr (off + 2)) in 
-    return @@ node ~left:(singleton0 x0)
-      ~right:(singleton0 x2)
-      ~key:x1
-      ~h:2
-  | _ ->  
-    let nl = len / 2 in 
-    let left = ofSortedArrayAux arr off nl in 
-    let mid = A.unsafe_get arr (off + nl) in 
-    let right = 
-      ofSortedArrayAux arr (off + nl + 1) (len - nl - 1) in 
-    create left mid right    
 
 
 

jscomp/others/bs_internalSet.ml

@@ -244,7 +244,7 @@ let rec findNull0 ~cmp (n : _ t0) x =
     else findNull0 ~cmp  (if c < 0 then N.left t else N.right t) x 
 
 
-
+(************************************************************************)
 let rec addMutate ~cmp (t : _ t0) x =   
   match N.toOpt t with 
   | None -> N.(return @@ node ~left:empty ~right:empty ~key:x ~h:1)
@@ -296,15 +296,16 @@ let rec sortedLengthAux ~cmp (xs : _ array) prec acc len =
   if  acc >= len then acc 
   else 
     let v = A.unsafe_get xs acc in 
-    if (Bs_Cmp.getCmp cmp) v  prec [@bs] >= 0 then 
+    if cmp v  prec [@bs] >= 0 then 
       sortedLengthAux ~cmp xs v (acc + 1) len 
     else acc    
 
 let ofArray0 ~cmp (xs : _ array) =   
   let len = A.length xs in 
   if len = 0 then N.empty0
   else
-    let next = sortedLengthAux ~cmp xs (A.unsafe_get xs 0) 1 len in 
+    let next = sortedLengthAux 
+      ~cmp:(Bs_Cmp.getCmp cmp) xs (A.unsafe_get xs 0) 1 len in 
     let result  = ref (N.ofSortedArrayAux  xs 0 next) in 
     for i = next to len - 1 do 
       result := addMutate ~cmp !result (A.unsafe_get xs i)