(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_rbtree.ml

  Copyright (c) 2004-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

type 'a node =
    | R of 'a * 'a node * 'a node
    | B of 'a * 'a node * 'a node
    | Z

module type Node_T = sig
    module Key: Cf_ordered.Total_T

    type +'a t

    val cons: Key.t -> 'a -> 'a t
    val key: 'a t -> Key.t
    val obj: 'a t -> 'a
    
    val kcompare: Key.t -> 'a t -> int
    val compare: 'a t -> 'a t -> int
end

module Core(N: Node_T) = struct
    module N = N

    (*
    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 ->
            ()
        | IC_r y when N.compare x y > 0 ->
            ()
        | IC_l y when N.compare x y < 0 ->
            ()
        | _ ->
            failwith "key out of order"
    
    let invariant_print_aux_ =
        let rec loop (ic : 'a ic) = function
            | Z ->
                Format.printf "Z@\n";
                0
            | R (_, R (_, _, _), _) ->
                Format.printf "@[<2>R@\nR@\n";
                failwith "red node has red child"
            | R (x, a, R (_, _, _)) ->
                Format.printf "@[<2>R@\n";
                let _ = loop (IC_l x) a in
                Format.printf "R@\n";
                failwith "red node has red child"
            | R (x, a, b) ->
                Format.printf "@[<2>R@\n";
                invariant_key_compare_ x ic;
                let a = loop (IC_l x) a in
                let b = loop (IC_r x) b in
                Format.printf "a=%d,b=%d@]@\n" a b;
                begin
                    match a, b with
                    | h1, h2 when h1 = h2 -> h1
                    | _ -> failwith "imbalanced black height"
                end
            | B (x, a, b) ->
                Format.printf "@[<2>B@\n";
                invariant_key_compare_ x ic;
                let a = loop (IC_l x) a in
                let b = loop (IC_r x) b in
                Format.printf "a=%d,b=%d@]@\n" a b;
                begin
                    match a, b with
                    | h1, h2 when h1 = h2 -> h1 + 1
                    | _ -> failwith "imbalanced black height"
                end
        in
        fun u ->
            Format.printf "| >invariant:@\n  @[<2>";
            match try `Okay (loop IC_o u) with x -> `Error x with
            | `Okay h ->
                Format.printf "@]@\n| <invariant (height=%d)@." h;
                flush stdout;
                true
            | `Error x ->
                Format.printf "!!!@.";
                flush stdout;
                raise x
    
    let invariant_noprint_aux_ =
        let rec loop = function
            | Z ->
                0
            | R (_, R (_, _, _), _)
            | R (_, _, R (_, _, _)) ->
                failwith "red node with red child"
            | R (_, a, b) ->
                begin
                    match loop a, loop b with
                    | h1, h2 when h1 = h2 -> h1
                    | _ -> failwith "imbalanced black height"
                end
            | B (_, a, b) ->
                begin
                    match loop a, loop b with
                    | h1, h2 when h1 = h2 -> h1 + 1
                    | _ -> failwith "imbalanced black height"
                end
        in
        fun u ->
            try ignore (loop u); true with Failure _ -> false
            (* ignore (loop u); true *)
            (* try ignore (loop u); true with Failure _ as x -> false *)
    
    let invariant_aux_ = invariant_noprint_aux_
    *)
    
    let nil = Z
    
    let empty = function Z -> true | _ -> false
    
    let rec size = function
        | Z ->
            0
        | R (_, a, b)
        | B (_, a, b) ->
            succ (size a + size b)
    
    let rec min = function
        | Z ->
            raise Not_found
        | R (x, Z, _)
        | B (x, Z, _) ->
            x
        | R (_, y, _)
        | B (_, y, _) ->
            min y
            
    let rec max = function
        | Z ->
            raise Not_found
        | R (x, _, Z)
        | B (x, _, Z) ->
            x
        | R (_, _, y)
        | B (_, _, y) ->
            max y
    
    let rec search key = function
        | Z ->
            raise Not_found
        | (R (n, a, b) | B (n, a, b)) ->
            let d = N.kcompare key n in
            if d = 0 then n else search key (if d < 0 then a else b)

    let rec member key = function
        | Z ->
            false
        | (R (n, a, b) | B (n, a, b)) ->
            let d = N.kcompare key n in
            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
        | R (y, R (x, a, b), c), d
        | R (x, a, R (y, b, c)), d ->
            R (y, B (x, a, b), B (z, c, d))
        | _ ->
            B (z, n1, n2)

    let r_balance_ z n1 n2 =
        match n1, n2 with
        | a, R (y, b, R (x, c, d))
        | a, R (x, R (y, b, c), d) ->
            R (y, B (z, a, b), B (x, c, d))
        | _ ->
            B (z, n1, n2)
    
    let rec replace_aux_ x = function
        | Z ->
            R (x, Z, Z)
        | R (y, a, b) ->
            let d = N.compare x y in
            if d < 0 then
                R (y, replace_aux_ x a, b)
            else if d > 0 then
                R (y, a, replace_aux_ x b)
            else
                R (x, a, b)
        | B (y, a, b) ->
            let d = N.compare x y in
            if d < 0 then
                l_balance_ y (replace_aux_ x a) b
            else if d > 0 then
                r_balance_ y a (replace_aux_ x b)
            else
                B (x, a, b)
    
    let force_black_ = function
        | R (n, a, b) -> B (n, a, b)
        | u -> u

    let replace x u =
        let u = force_black_ (replace_aux_ x u) in
        (* assert (invariant_aux_ u); *)
        u
    
    let l_repair_ = function
        | R (x, B (y, a, b), c) ->
            l_balance_ x (R (y, a, b)) c, false
        | B (x, B (y, a, b), c) ->
            l_balance_ x (R (y, a, b)) c, true
        | B (x, R (y, a, B (z, b, c)), d) ->
            B (y, a, l_balance_ x (R (z, b, c)) d), false
        | _ ->
            assert (not true);
            Z, false
    
    let r_repair_ = function
        | R (x, a, B (y, b, c)) ->
            r_balance_ x a (R (y, b, c)), false
        | B (x, a, B (y, b, c)) ->
            r_balance_ x a (R (y, b, c)), true
        | B (x, a, R (y, B (z, b, c), d)) ->
            B (y, r_balance_ x a (R (z, b, c)), d), false
        | _ ->
            assert (not true);
            Z, false

    let dup_color_ x a b = function
        | Z -> assert (not true); R (x, a, b)
        | R _ -> R (x, a, b)
        | B _ -> B (x, a, b)
    
    let rec extract_min_ = function
        | Z
        | B (_, Z, B _) ->
            assert (not true);
            extract_min_ Z
        | B (x, Z, Z) ->
            Z, x, true
        | B (x, Z, R (y, a, b)) ->
            B (y, a, b), x, false
        | R (x, Z, a) ->
            a, x, false
        | (R (x, a, b) | B (x, a, b)) as n ->
            let a, m, r = extract_min_ a in
            let n = dup_color_ x a b n in
            if r then
                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) -> 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 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 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 match b with
        | Z ->
            ifdz a
        | b ->
            let b, z, d = extract_min_ b in
            let n = cons z a b in
            if d then l_repair_ n else n, false
        
    let delete k u =
        try
            let u, _ = delete_aux_ k u in
            (* assert (invariant_aux_ u); *)
            u
        with
        | Not_found ->
            u

    let rec of_list_aux_ acc = function
        | hd :: tl -> of_list_aux_ (replace hd acc) tl
        | [] -> acc
    
    let of_list s = of_list_aux_ nil s
    
    let rec of_seq_aux_ acc seq =
        match Lazy.force seq with
        | Cf_seq.P (hd, tl) -> of_seq_aux_ (replace hd acc) tl
        | Cf_seq.Z -> acc
    
    let of_seq z = of_seq_aux_ nil z
    
    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) ]
        | Y (m, y) :: t -> X (m, y, n, x) :: t
        | X (m, y, p, z) :: t -> Y (n, x) :: (accum_incr_ (B (y, m, p)) z t)

    let rec accum_decr_ n x = function
        | [] -> [ Y (n, x) ]
        | Y (m, y) :: t -> X (n, x, m, y) :: t
        | X (p, z, m, y) :: t -> Y (n, x) :: (accum_decr_ (B (y, p, m)) z t)
    
    let rec final_incr_ acc = function
        | [] -> acc
        | Y (m, y) :: t -> final_incr_ (B (y, m, acc)) t
        | X (m, y, p, z) :: t -> final_incr_ (B (y, m, R (z, p, acc))) t
    
    let rec final_decr_ acc = function
        | [] -> acc
        | Y (m, y) :: t -> final_decr_ (B (y, acc, m)) t
        | X (p, z, m, y) :: t -> final_decr_ (B (y, R (z, acc, p), m)) t

    let of_list_incr =
        let rec loop last acc = function
            | hd :: tl -> 
                if N.compare last hd > 0 then
                    of_list_aux_ (replace hd (final_incr_ Z acc)) tl
                else
                    loop hd (accum_incr_ Z hd acc) tl
            | [] ->
                final_incr_ Z acc
        in
        function
        | [] -> Z
        | hd :: tl -> loop hd [ Y (Z, hd) ] tl

    let of_list_decr =
        let rec loop last acc = function
            | hd :: tl -> 
                if N.compare last hd < 0 then
                    of_list_aux_ (replace hd (final_decr_ Z acc)) tl
                else
                    loop hd (accum_decr_ Z hd acc) tl
            | [] ->
                final_incr_ Z acc
        in
        function
        | [] -> Z
        | hd :: tl -> loop hd [ Y (Z, hd) ] tl

    let of_seq_incr =
        let rec loop last acc z =
            match Lazy.force z with
            | Cf_seq.P (hd, tl) -> 
                if N.compare last hd > 0 then
                    of_seq_aux_ (replace hd (final_incr_ Z acc)) tl
                else
                    loop hd (accum_incr_ Z hd acc) tl
            | Cf_seq.Z ->
                final_incr_ Z acc
        in
        fun z ->
            match Lazy.force z with
            | Cf_seq.Z -> Z
            | Cf_seq.P (hd, tl) -> loop hd [ Y (Z, hd) ] tl

    let of_seq_decr =
        let rec loop last acc z =
            match Lazy.force z with
            | Cf_seq.P (hd, tl) -> 
                if N.compare last hd < 0 then
                    of_seq_aux_ (replace hd (final_decr_ Z acc)) tl
                else
                    loop hd (accum_decr_ Z hd acc) tl
            | Cf_seq.Z ->
                final_decr_ Z acc
        in
        fun z ->
            match Lazy.force z with
            | Cf_seq.Z -> Z
            | Cf_seq.P (hd, tl) -> loop hd [ Y (Z, hd) ] tl
    
    type 'a stack = ('a * 'a node) list
    
    let rec stack_min_ i = function
        | Z ->
            i
        | R (e, a, b)
        | B (e, a, b) ->
            stack_min_ ((e, b) :: i) a
    
    let rec stack_max_ i = function
        | Z ->
            i
        | R (e, a, b)
        | B (e, a, b) ->
            stack_max_ ((e, a) :: i) b
    
    let to_list_aux_ =
        let rec loop f acc = function
            | (e, s) :: tl ->
                let tl = match s with Z -> tl | _ -> f tl s in
                loop f (e :: acc) tl
            | [] ->
                acc (* reversed *)
        in
        fun f g u ->
            loop f [] (f g u)

    let to_list_incr u = to_list_aux_ stack_max_ [] u
    let to_list_decr u = to_list_aux_ stack_min_ [] u

    let to_seq_aux_ =
        let rec loop f = function
            | (e, s) :: tl ->
                let tl = match s with Z -> tl | _ -> f tl s in
                Cf_seq.P (e, lazy (loop f tl))
            | [] ->
                Cf_seq.Z
        in
        fun f g u ->
            lazy (loop f (f g u))

    let to_seq_incr u = to_seq_aux_ stack_min_ [] u
    let to_seq_decr u = to_seq_aux_ stack_max_ [] u
        
    let rec nearest_incr_aux_ key w = function
        | Z ->
            to_seq_aux_ stack_min_ w Z
        | R (n, a, b)
        | B (n, a, b) ->
            let d = N.kcompare key n in
            if d = 0 then
                lazy (Cf_seq.P (n, to_seq_aux_ stack_min_ w b))
            else
                let w, n = if d < 0 then (n, b) :: w, a else w, b in
                nearest_incr_aux_ key w n
    
    let rec nearest_decr_aux_ key w = function
        | Z ->
            to_seq_aux_ stack_max_ w Z
        | R (n, a, b)
        | B (n, a, b) ->
            let d = N.kcompare key n in
            if d = 0 then
                lazy (Cf_seq.P (n, to_seq_aux_ stack_max_ w a))
            else
                let w, n = if d > 0 then (n, a) :: w, b else w, a in
                nearest_decr_aux_ key w n
    
    let nearest_incr key u = nearest_incr_aux_ key [] u
    let nearest_decr key u = nearest_decr_aux_ key [] u
    
    let rec iterate f = function
        | Z ->
            ()
        | B (n, a, b)
        | R (n, b, a) ->
            f n; iterate f a; iterate f b
    
    let rec predicate f = function
        | Z ->
            true
        | B (n, a, b)
        | R (n, b, a) ->
            f n && predicate f a && predicate f b
    
    let rec fold f x = function
        | Z ->
            x
        | B (n, a, b)
        | R (n, b, a) ->
            fold f (fold f (f x n) a) b

    let rec filter_aux_ v f = function
        | Z ->
            v
        | B (n, a, b)
        | R (n, b, a) ->
            let v = if f n then replace n v else v in
            filter_aux_ (filter_aux_ v f a) f b

    let filter f u = filter_aux_ Z f u
    
    let rec map f = function
        | Z ->
            Z
        | R (n, a, b) ->
            R (N.cons (N.key n) (f n), map f a, map f b)
        | B (n, a, b) ->
            B (N.cons (N.key n) (f n), map f a, map f b)
    
    let rec optmap_aux_ v f = function
        | Z ->
            v
        | B (n, a, b)
        | R (n, b, a) ->
            let v =
                match f n with
                | Some n' -> replace (N.cons (N.key n) n') v
                | None -> v
            in
            optmap_aux_ (optmap_aux_ v f a) f b
            
    let optmap f u = optmap_aux_ Z f u
    
    let rec partition_aux_ (v1, v2 as v) f = function
        | Z ->
            v
        | B (n, a, b)
        | R (n, b, a) ->
            let v = if f n then replace n v1, v2 else v1, replace n v2 in
            partition_aux_ (partition_aux_ v f a) f b
    
    let partition f u = partition_aux_ (Z, Z) f u
end

module Set(E: Cf_ordered.Total_T): (Cf_set.T with module Element = E) = struct
    include Core(struct
        module Key = E
        
        type 'a t = E.t
        
        let cons k _ = k
        let key k = k
        let obj v = assert (not true); Obj.magic v
        
        let kcompare x y = E.compare x y
        let compare x y = E.compare x y
    end)
    
    module Element = E
    type t = E.t node
        
    let put = replace
    let clear = delete

    let singleton x = replace x nil

    let compare s0 s1 =
        Cf_seq.fcmp E.compare (to_seq_incr s0) (to_seq_incr s1)
    
    let put_swap_ s x = replace x s
    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 rec subset s1 s2 =
        match s1, s2 with
        | Z, _ ->
            true
        | _, Z ->
            false
        | (R (x1, a1, b1) | (B (x1, a1, b1))),
          (R (x2, a2, b2) | (B (x2, a2, b2))) ->
            let dx = E.compare x1 x2 in
            if dx = 0 then
                subset a1 a2 && subset b1 b2
            else if dx < 0 then
                subset (B (x1, a1, Z)) a2 && subset b1 s2
            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
        | B (_, a, _) -> height_ (succ acc) a
    
    let rec join_ x a b ah bh =
        match a, b with
        | Z, y
        | y, Z ->
            let y = replace x y in
            height_ 0 y, y
        | _, _ ->
            let dh = bh - ah in
            if dh < 0 then begin
                let bh', bx, ba, bb =
                    match b with
                    | Z -> assert (not true); bh, x, a, b
                    | R (x, a, b) -> bh, x, a, b
                    | B (x, a, b) -> pred bh, x, a, b
                in
                let ah', ba = join_ x a ba ah bh' in
                join_ bx ba bb ah' bh'
            end
            else begin
                assert (dh = 0);
                succ ah, B (x, a, b)
            end
    
    let rec build_dn_ n z =
        assert (n > 0);
        match Lazy.force z with
        | Cf_seq.Z ->
            0, Z, z
        | Cf_seq.P (x, z) when n = 1 ->
            1, B (x, Z, Z), z
        | _ ->
            let n = pred n in
            let ah, a, z = build_dn_ n z in
            match Lazy.force z with
            | Cf_seq.Z ->
                ah, a, z
            | Cf_seq.P (x, z) ->
                let bh, b, z = build_dn_ n z in
                let h, u = join_ x a b ah bh in
                h, u, z
    
    let rec build_up_ ah a n z =
        match Lazy.force z with
        | Cf_seq.Z ->
            ah, a, z
        | Cf_seq.P (x, z) when n = 0 && a = Z ->
            assert (ah = 0);
            build_up_ 1 (B (x, Z, Z)) (succ n) z
        | Cf_seq.P (x, z) ->
            let bh, b, z = build_dn_ n z in
            let h, a = join_ x a b ah bh in
            build_up_ h a (succ n) z
    
    let build_ z =
        let _, u, z = build_up_ 0 Z 0 z in
        assert (Cf_seq.Z = Lazy.force z);
        (* let u = paint_black_ u in *)
        (* assert (invariant_aux_ u); *)
        u

    let rec union_seq_ z1 z2 =
        lazy begin
            match Lazy.force z1, Lazy.force z2 with
            | Cf_seq.Z, Cf_seq.Z ->
                Cf_seq.Z
            | Cf_seq.Z, z
            | z, Cf_seq.Z ->
                z
            | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) ->
                let dx = E.compare hd1 hd2 in
                if dx = 0 then
                    Cf_seq.P (hd1, union_seq_ tl1 tl2)
                else if dx < 0 then
                    Cf_seq.P (hd1, union_seq_ tl1 z2)
                else
                    Cf_seq.P (hd2, union_seq_ z1 tl2)
        end
    
    let union s1 s2 =
        let z1 = to_seq_incr s1 and z2 = to_seq_incr s2 in
        build_ (union_seq_ z1 z2)
    
    let rec intersect_seq_ z1 z2 =
        lazy begin
            match Lazy.force z1, Lazy.force z2 with
            | Cf_seq.Z, Cf_seq.Z ->
                Cf_seq.Z
            | Cf_seq.Z, z
            | z, Cf_seq.Z ->
                z
            | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) ->
                let dx = E.compare hd1 hd2 in
                if dx = 0 then
                    Cf_seq.P (hd1, intersect_seq_ tl1 tl2)
                else if dx < 0 then
                    Lazy.force (intersect_seq_ tl1 z2)
                else
                    Lazy.force (intersect_seq_ z1 tl2)
        end
    
    let intersect s1 s2 =
        let z1 = to_seq_incr s1 and z2 = to_seq_incr s2 in
        build_ (intersect_seq_ z1 z2)

    let rec diff_seq_ z1 z2 =
        lazy begin
            match Lazy.force z1, Lazy.force z2 with
            | Cf_seq.Z, Cf_seq.Z ->
                Cf_seq.Z
            | Cf_seq.Z, z
            | z, Cf_seq.Z ->
                z
            | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) ->
                let dx = E.compare hd1 hd2 in
                if dx = 0 then
                    Lazy.force (diff_seq_ tl1 tl2)
                else if dx < 0 then
                    Cf_seq.P (hd1, diff_seq_ tl1 z2)
                else
                    Lazy.force (diff_seq_ z1 tl2)
        end
    
    let diff s1 s2 =
        let z1 = to_seq_incr s1 and z2 = to_seq_incr s2 in
        build_ (diff_seq_ z1 z2)
    *)
end

module Map(K: Cf_ordered.Total_T) = struct
    include Core(struct
        module Key = K
        type 'a t = Key.t * 'a
        
        let cons k v = k, v
        let key (k, _) = k
        let obj (_, v) = v
        
        let kcompare x (y, _) = Key.compare x y
        let compare (x, _) (y, _) = Key.compare x y
    end)

    module Key = K
    
    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); *)
        N.obj v, u
    
    let rec insert_aux_ x = function
        | Z ->
            R (x, Z, Z), None
        | R (y, a, b) ->
            let d = N.compare x y in
            if d < 0 then begin
                let a, xopt = insert_aux_ x a in
                R (y, a, b), xopt
            end
            else if d > 0 then begin
                let b, xopt = insert_aux_ x b in
                R (y, a, b), xopt
            end
            else begin
                let _, y = y in
                R (x, a, b), Some y
            end
        | B (y, a, b) ->
            let d = N.compare x y in
            if d < 0 then begin
                let a, xopt = insert_aux_ x a in
                l_balance_ y a b, xopt
            end
            else if d > 0 then begin
                let b, xopt = insert_aux_ x b in
                r_balance_ y a b, xopt
            end
            else begin
                let _, y = y in
                R (x, a, b), Some y
            end

    let insert x u =
        let u, xopt = insert_aux_ x u in
        let u = force_black_ u in
        (* assert (invariant_aux_ u); *)
        u, xopt
    
    let rec modify key f = function
        | Z ->
            raise Not_found
        | (B (x, a, b) | R (x, a, b)) as u ->
            let d = N.kcompare key x in
            if d < 0 then
                dup_color_ x (modify key f a) b u
            else if d > 0 then
                dup_color_ x a (modify key f b) u
            else
                dup_color_ (N.cons key (f (N.obj x))) a b u
end

(*--- End of File [ cf_rbtree.ml ] ---*)
