Commits

Anonymous committed a921d09

Submit cf-0.2 release.

  • Participants
  • Parent commits e753896

Comments (0)

Files changed (14)

File cf/cf_pqueue.ml

+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  cf_pqueue.ml
+
+  Copyright (c) 2004, 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. 
+ *---------------------------------------------------------------------------*)
+
+module type T = sig
+    type +'a t
+
+    module Key: sig type t end
+    
+    val nil: 'a t
+    val empty: 'a t -> bool
+    val size: 'a t -> int
+    val head: 'a t -> (Key.t * 'a)
+    val tail: 'a t -> 'a t
+    val pop: 'a t -> ((Key.t * 'a) * 'a t) option
+    val put: (Key.t * 'a) -> 'a t -> 'a t
+    val merge: 'a t -> 'a t -> 'a t
+    val iterate: ((Key.t * 'a) -> unit) -> 'a t -> unit
+    val predicate: ((Key.t * 'a) -> bool) -> 'a t -> bool
+    val fold: ('b -> (Key.t * 'a) -> 'b) -> 'b -> 'a t -> 'b
+    val filter: ((Key.t * 'a) -> bool) -> 'a t -> 'a t
+    val map: ((Key.t * 'a) -> 'b) -> 'a t -> 'b t
+    val optmap: ((Key.t * 'a) -> 'b option) -> 'a t -> 'b t
+    val partition: ((Key.t * 'a) -> bool) -> 'a t -> 'a t * 'a t
+    val of_seq: (Key.t * 'a) Cf_seq.t -> 'a t
+    val of_list: (Key.t * 'a) list -> 'a t
+    val to_seq: 'a t -> (Key.t * 'a) Cf_seq.t
+    val to_seq2: 'a t -> ((Key.t * 'a) * 'a t) Cf_seq.t
+end
+
+(*--- End of File [ cf_pqueue.ml ] ---*)

File cf/cf_pqueue.mli

+(*---------------------------------------------------------------------------*
+  INTERFACE  cf_pqueue.mli
+
+  Copyright (c) 2004, 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. 
+ *---------------------------------------------------------------------------*)
+
+
+(** A module type for functional priority queue implementations. *)
+
+(** {6 Module Type} *)
+
+(**
+    This module defines the common interface to functional priority queues in
+    the {!Cf} library.
+*)
+module type T = sig
+    
+    (** The priority queue type *)
+    type +'a t
+
+    (** A module defining the type of the key.  Some map implementations may
+        define more functions in this module for disambiguating keys from one
+        another.
+    *)
+    module Key: sig type t end
+    
+    (** The empty priority queue. *)
+    val nil: 'a t
+    
+    (** Use [empty q] to test whether the priority queue [q] is empty. *)
+    val empty: 'a t -> bool
+    
+    (** Use [size q] to count the number of elements in the priority queue [q].
+    *)
+    val size: 'a t -> int
+    
+    (** Use [head q] to obtain the element on the top of the priority queue
+        [q].  Raises [Not_found] if the queue is empty.
+    *)
+    val head: 'a t -> (Key.t * 'a)
+    
+    (** Use [tail q] to obtain the heap produced by discarding the element on
+        the top of the priority queue [q].  If [q] is the empty queue, then the
+        empty queue is returned.
+    *)
+    val tail: 'a t -> 'a t
+    
+    (** Use [pop q] to obtain the head and the tail of a priority queue [q] in
+        one operation.  Returns [None] if the queue [q] is empty.
+    *)
+    val pop: 'a t -> ((Key.t * 'a) * 'a t) option
+    
+    (** Use [put e q] to obtain a new priority queue that is the result of
+        inserting the element [e] into the queue [q].
+    *)
+    val put: (Key.t * 'a) -> 'a t -> 'a t
+    
+    (** Use [merge q1 q2] to obtain a new priority queue that is the result of
+        merging all the elements of [q1] and [q2] into a single heap.
+    *)
+    val merge: 'a t -> 'a t -> 'a t
+
+    (** Use [iterate f q] to apply [f] to every element in the priority queue
+        [q] in an arbitrary order (not top to bottom).
+    *)
+    val iterate: ((Key.t * 'a) -> unit) -> 'a t -> unit
+    
+    (** Use [predicate f q] to test whether all the elements in priority queue
+        [q] satisfy the predicate function [f].  Visits the elements in the
+        queue in arbitrary order (not top to bottom).
+    *)
+    val predicate: ((Key.t * 'a) -> bool) -> 'a t -> bool
+    
+    (** Use [fold f s q] to produce the result of folding a value [s] into
+        the elements of priority queue [q] with the folding function [f] in an
+        arbitrary order (not top to bottom).
+    *)
+    val fold: ('b -> (Key.t * 'a) -> 'b) -> 'b -> 'a t -> 'b
+    
+    (** Use [filter f q] to apply [f] to each element in the priority queue [q]
+        in an arbitrary order (not to top bottom), and produce a new heap that
+        contains only those elements for which [f pair] returned [true].
+    *)
+    val filter: ((Key.t * 'a) -> bool) -> 'a t -> 'a t
+    
+    (** Use [map f q] to obtain a new heap by applying the mapping function [f]
+        to the key and the value of every element in the priority queue [q] to
+        obtain a mapped element with the same key and a new value.  The
+        elements of [q] are visited in an arbitrary order (not top to bottom).
+    *)
+    val map: ((Key.t * 'a) -> 'b) -> 'a t -> 'b t
+    
+    (** Use [optmap f q] to obtain a new heap by applying the mapping function
+        [f] to the key and the value of every element in priority queue [q] to
+        obtain a mapped element with the same key and a new value.  The
+        elements of [q] are visited in an arbitrary order (not top to bottom).
+        When [f] returns [None] for a given key, that key will not be present
+        in the new queue.
+    *)
+    val optmap: ((Key.t * 'a) -> 'b option) -> 'a t -> 'b t
+    
+    (** Use [partition f q] to obtain a pair of new priority queues that are
+        the result of applying the partitioning function [f] to each element in
+        the queue [q] in an arbitrary order (not top to bottom).  The first
+        queue returned will contain all the elements for which [f pair]
+        returned true, and the second queue will return all the remaining
+        elements.
+    *)
+    val partition: ((Key.t * 'a) -> bool) -> 'a t -> 'a t * 'a t
+
+    (** Use [of_seq z] to construct a priority queue from a sequence of
+        elements.  Evaluates the whole sequence.
+    *)
+    val of_seq: (Key.t * 'a) Cf_seq.t -> 'a t
+    
+    (** Use [of_list s] to construct a priority queue from a list of elements.
+    *)
+    val of_list: (Key.t * 'a) list -> 'a t
+    
+    (** Use [to_seq q] to produce a sequence of elements in top to bottom order
+        from the priority queue [q].
+    *)
+    val to_seq: 'a t -> (Key.t * 'a) Cf_seq.t
+    
+    (** Use [to_seq2 q] to produce a sequence of elements from the priority
+        queue [q], where the first element of each pair is a key-value pair
+        obtained from the head of the queue, and the second element of the
+        pair is the corresponding tail of the queue.
+    *)
+    val to_seq2: 'a t -> ((Key.t * 'a) * 'a t) Cf_seq.t
+end
+
+(*--- End of File [ cf_pqueue.mli ] ---*)

File cf/cf_rbtree.ml

 (*---------------------------------------------------------------------------*
-  IMPLEMENTATION  cf_rbtree.ml
+  IMPLEMENTATION  cf_rbt.ml
 
-  Copyright (c) 2002-2004, James H. Woodyatt
+  Copyright (c) 2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-module type T = sig
+type 'a node_t =
+    | R of 'a * 'a node_t * 'a node_t
+    | B of 'a * 'a node_t * 'a node_t
+    | Z
+
+module type Node_T = sig
     module Key: Cf_ordered.Total_T
-    module Pair: Cf_ordered.KV_Pair_T with module Key = Key
+
+    type +'a t
+
+    val cons: Key.t -> 'a -> 'a t
+    val key: 'a t -> Key.t
+    val obj: 'a t -> 'a
     
-    type +'a t
-    
-    val nil: 'a t
-    val empty: 'a t -> bool
-    val size: 'a t -> int
-    
-    val min: 'a t -> 'a Pair.t
-    val max: 'a t -> 'a Pair.t
-
-    val search: Key.t -> 'a t -> 'a
-    val member: Key.t -> 'a t -> bool
-    
-    val nearest_pred: Key.t -> 'a t -> 'a Pair.t
-    val nearest_succ: Key.t -> 'a t -> 'a Pair.t
-
-    val insert: 'a Pair.t -> 'a t -> 'a t * 'a option
-    val replace: 'a Pair.t -> 'a t -> 'a t
-    val modify: Key.t -> ('a -> 'a) -> 'a t -> 'a t
-    val extract: Key.t -> 'a t -> 'a * 'a t
-    val delete: Key.t -> 'a t -> 'a t
-    
-    val iterate: ('a Pair.t -> unit) -> 'a t -> unit
-    val predicate: ('a Pair.t -> bool) -> 'a t -> bool
-    val fold: ('b -> 'a Pair.t -> 'b) -> 'b -> 'a t -> 'b
-    val filter: ('a Pair.t -> bool) -> 'a t -> 'a t
-    val map: (Key.t -> 'a -> 'b) -> 'a t -> 'b t
-    val optmap: ('a Pair.t -> 'b option) -> 'a t -> 'b t
-    val partition: ('a Pair.t -> bool) -> 'a t -> 'a t * 'a t
-
-    val increasing: 'a t -> 'a Pair.t Cf_seq.t
-    val decreasing: 'a t -> 'a Pair.t Cf_seq.t
-    
-    val of_seq: 'a Pair.t Cf_seq.t -> 'a t
-    val of_list: 'a Pair.t list -> 'a t
+    val kcompare: Key.t -> 'a t -> int
+    val compare: 'a t -> 'a t -> int
 end
 
-module Create(K: Cf_ordered.Total_T) (* : (T with module Key = K) *) = struct
-    module Key = K
-    module Pair = Cf_ordered.KV_Pair(K)
+module Core(N: Node_T) = struct
+    module N = N
+
+    (**)
+    type 'a ic_t = IC_o | IC_l of 'a N.t | IC_r of 'a N.t
     
-    type color_t = B | R
-    type 'a t = Z | N of 'a Pair.t * color_t * 'a t * 'a 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 color_name_ = function B -> "Black" | R -> "Red"
-
-    (*
     let invariant_print_aux_ =
-        let rec loop = function
+        let rec loop (ic : 'a ic_t) = function
             | Z ->
                 Format.printf "Z@\n";
                 0
-            | N (_, R, N (_, R, _, _), _) ->
+            | R (_, R (_, _, _), _) ->
                 Format.printf "@[<2>R@\nR@\n";
                 failwith "red node has red child"
-            | N (_, R, a, N (_, R, _, _)) ->
+            | R (x, a, R (_, _, _)) ->
                 Format.printf "@[<2>R@\n";
-                let _ = loop a in
+                let _ = loop (IC_l x) a in
                 Format.printf "R@\n";
                 failwith "red node has red child"
-            | N (_, color, a, b) ->
-                Format.printf "@[<2>%s@\n" (color_name_ color);
-                let a = loop a in
-                let b = loop b in
+            | 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;
-                match a, b with
-                | h1, h2 when h1 = h2 -> if color = B then h1 + 1 else h1
-                | _ -> failwith "imbalanced black height"
+                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 subtree ->
+        fun u ->
             Format.printf "| >invariant:@\n  @[<2>";
-            match try `Okay (loop subtree) with x -> `Error x with
+            match try `Okay (loop IC_o u) with x -> `Error x with
             | `Okay h ->
                 Format.printf "@]@\n| <invariant (height=%d)@." h;
                 flush stdout;
         let rec loop = function
             | Z ->
                 0
-            | N (_, R, N (_, R, _, _), _)
-            | N (_, R, _, N (_, R, _, _)) ->
+            | R (_, R (_, _, _), _)
+            | R (_, _, R (_, _, _)) ->
                 failwith "red node with red child"
-            | N (_, color, a, b) ->
-                match loop a, loop b with
-                | h1, h2 when h1 = h2 -> if color = B then h1 + 1 else h1
-                | _ -> failwith "imbalanced black height"
+            | 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 subtree ->
-            try ignore (loop subtree); true with Failure _ as x -> false
+        fun u ->
+            try ignore (loop u); true with Failure _ as x -> false
 
-            (* ignore (loop subtree); true *)
-            (* try ignore (loop subtree); true with Failure _ as x -> 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
-        | N (_, _, a, b) -> 1 + size a + size b
+        | Z ->
+            0
+        | R (_, a, b)
+        | B (_, a, b) ->
+            succ (size a + size b)
+
+    let rec min_aux_ = function
+        | Z ->
+            raise Not_found
+        | (R (_, Z, _) as x)
+        | (B (_, Z, _) as x) ->
+            x
+        | R (_, y, _)
+        | B (_, y, _) ->
+            min_aux_ y
+
+    let rec max_aux_ = function
+        | Z ->
+            raise Not_found
+        | (R (_, _, Z) as x)
+        | (B (_, _, Z) as x) ->
+            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
     
-    let rec minloop_ = function
-        | N (_, _, (N _ as y), _) -> minloop_ y
-        | x -> x
-    
-    let rec maxloop_ = function
-        | N (_, _, _, (N _ as y)) -> maxloop_ y
-        | x -> x
-    
-    let min x =
-        match minloop_ x with
-        | N (pair, _, _, _) -> pair
-        | Z -> raise Not_found
-    
-    let max x =
-        match maxloop_ x with
-        | N (pair, _, _, _) -> pair
-        | Z -> raise Not_found
-
     let rec search key = function
         | Z ->
             raise Not_found
-        | N ((key', content), _, a, b) ->
-            let d = Key.compare key key' in
+        | (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
+            d = 0 || 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) as s ->
+            let d = N.compare x y in
             if d < 0 then
-                search key a
+                R (y, replace_aux_ x a, b)
             else if d > 0 then
-                search key b
+                R (y, a, replace_aux_ x b)
             else
-                content
+                R (x, a, b)
+        | B (y, a, b) as s ->
+            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 member key x = try let _ = search key x in true with Not_found -> false
+    let replace x u =
+        let u = force_black_ (replace_aux_ x u) in
+        (**) assert (invariant_aux_ u); (**)
+        u
     
-    let rec nearest_pred_aux_ ~key root tree =
-        match tree with
-        | N ((key', _ as p), _, a, b) as root' ->
-            if Key.compare key key'  < 0 then
-                nearest_pred_aux_ ~key root a
+    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
-                nearest_pred_aux_ ~key root' b
-        | Z ->
-            match root with
-            | N (pair, _, _, _) -> pair
-            | Z -> raise Not_found
+                n, m, false
     
-    let nearest_pred key tree = nearest_pred_aux_ ~key Z tree
-    
-    let rec nearest_succ_aux_ ~key root tree =
-        match tree with
-        | N ((key', _ as p), _, a, b) as root' ->
-            if Key.compare key key' > 0 then
-                nearest_succ_aux_ ~key root b
-            else
-                nearest_succ_aux_ ~key root' a
-        | Z ->
-            match root with
-            | N (pair, _, _, _) -> pair
-            | Z -> raise Not_found
-    
-    let nearest_succ key tree = nearest_succ_aux_ ~key Z tree
-
-    let force_black_ = function
-        | N (pair, _, a, b) -> N (pair, B, a, b)
-        | Z -> Z
-        
-    let ins_balance_ = function
-        | N (z, B, N (y, R, N (x, R, a, b), c), d)
-        | N (z, B, N (x, R, a, N (y, R, b, c)), d)
-        | N (x, B, a, N (z, R, N (y, R, b, c), d))
-        | N (x, B, a, N (y, R, b, N (z, R, c, d))) ->
-            N (y, R, N (x, B, a, b), N (z, B, c, d))
-        | n ->
-            n
-    
-    let rec ins_loop_ (key, _ as pair) = function
-        | Z ->
-            N (pair, R, Z, Z), None
-        | N ((key', y as pair'), color, a, b) as s ->
-            let d = Key.compare key key' in
-            if d < 0 then
-                let a, nopt = ins_loop_ pair a in
-                let n = N (pair', color, a, b) in
-                if nopt = None then
-                    ins_balance_ n, nopt
-                else
-                    n, nopt
-            else if d > 0 then
-                let b, nopt = ins_loop_ pair b in
-                let n = N (pair', color, a, b) in
-                if nopt = None then
-                    ins_balance_ n, nopt
-                else
-                    n, nopt
-            else
-                N (pair, color, a, b), Some y
-
-    let insert pair tree =
-        let root, replace = ins_loop_ pair tree in
-        let root = force_black_ root in
-        (* assert (invariant_aux_ root); *)
-        root, replace
-    
-    let replace pair tree =
-        let root, _ = ins_loop_ pair tree in
-        let root = force_black_ root in
-        (* assert (invariant_aux_ root); *)
-        root
-    
-    let rec modify key f = function
+    let rec extract_aux_ k = function
         | Z ->
             raise Not_found
-        | N ((key', y as pair'), color, a, b) as s ->
-            let d = Key.compare key key' in
-            if d < 0 then
-                N (pair', color, modify key f a, b)
-            else if d > 0 then
-                N (pair', color, a, modify key f b)
-            else
-                N ((key, f y), color, a, b)
-        
-    let rec del_bal_left_ x color a b =
-        match a, b with
-        | (Z | N (_, B, _, _)), N (y, R, b, c) ->
-            let db, a = del_bal_left_ x R a b in
-            if db then true, N (y, color, a, c) else del_bal_left_ y color a c
-        | a, N (z, B, N (y, R, b, c), d)
-        | a, N (y, B, b, N (z, R, c, d)) ->
-            true, N (y, color, N (x, B, a, b), N (z, B, c, d))
-        | a, N (y, B, b, c) ->
-            color = R, N (x, B, a, N (y, R, b, c))
-        | _ ->
-            assert (not true);
-            true, Z
-
-    let rec del_bal_right_ x color a b =
-        match a, b with
-        | N (y, R, a, b), (Z | N (_, B, _, _) as c) ->
-            let db, c = del_bal_right_ x R b c in
-            if db then true, N (y, color, a, c) else del_bal_right_ y color a c
-        | N (z, B, a, N (y, R, b, c)), d
-        | N (y, B, N (z, R, a, b), c), d ->
-            true, N (y, color, N (z, B, a, b), N (x, B, c, d))
-        | N (y, B, a, b), c ->
-            color = R, N (x, B, N (y, R, a, b), c)
-        | _ ->
-            assert (not true);
-            true, Z
-    
-    let rec del_loop_ z color a b =
-        match color, a, b with
-        | R, Z, _ ->
-            z, true, b
-        | B, Z, (N (x, R, a, b) as y) ->
-            z, true, N (x, B, a, b)
-        | B, Z, _ ->
-            z, false, b
-        | _, N (z', color', a', b'), _ ->
-            let z', bal, a = del_loop_ z' color' a' b' in
-            let bal, a =
-                if bal then true, N (z, color, a, b)
-                else del_bal_left_ z color a b
-            in
-            z', bal, a
-
-    let delete_ color a b =
-        match a, b with
-        | Z, Z ->
-            color = R, Z
-        | Z, (N (e, R, a, b) as y)
-        | (N (e, R, a, b) as y), Z ->
-            assert (color = B);
-            true, N (e, B, a, b)
-        | Z, y
-        | y, Z ->
-            assert (color = B);
-            false, y
-        | (N _ as a), (N (z', color', b0, b1) as b) ->
-            let y, bal, b = del_loop_ z' color' b0 b1 in
-            let bal, b =
-                if bal then true, N (y, color, a, b)
-                else del_bal_right_ y color a b
-            in
-            bal, b
-
-    let rec extract_loop_ key = function
-        | Z ->
-            raise Not_found
-        | N ((key', content as x), color, a, b) ->
-            let d = Key.compare key key' in
+        | B (y, a, b) ->
+            let d = N.kcompare k y in
             if d < 0 then begin
-                let e, bal, a = extract_loop_ key a in
-                let bal, a =
-                    if bal then true, N (x, color, a, b)
-                    else del_bal_left_ x color a b
-                in
-                e, bal, a
+                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 e, bal, b = extract_loop_ key b in
-                let bal, b =
-                    if bal then true, N (x, color, a, b)
-                    else del_bal_right_ x color a b
-                in
-                e, bal, b
+                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
-                let bal, y = delete_ color a b in
-                content, bal, y
-
-    let extract key tree =
-        let e, _, root = extract_loop_ key tree in
-        (* assert (invariant_aux_ root); *)
-        e, root
+            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
     
-    let delete key tree =
+    let delete k u =
         try
-            let _, _, root = extract_loop_ key tree in
-            (* assert (invariant_aux_ root); *)
-            root
+            let u, _, _ = extract_aux_ k u in
+            (**) assert (invariant_aux_ u); (**)
+            u
         with
         | Not_found ->
-            tree
+            u
     
-    let rec iterate f = function
-        | N (e, _, a, b) -> f e; iterate f a; iterate f b
-        | Z -> ()
-    
-    let rec predicate f = function
-        | N (e, _, a, b) -> f e && predicate f a && predicate f b
-        | Z -> true
-    
-    let rec fold f x = function
-        | N (e, _, a, b) -> fold f (fold f (f x e) a) b
-        | Z -> x
-    
-    let filter f =
-        let rec loop v = function
-            | Z ->
-                v
-            | N (pair, _, a, b) ->
-                let v =
-                    if f pair then
-                        let v, p = insert pair v in
-                        assert (p = None);
-                        v
-                    else
-                        v
-                in
-                loop (loop v a) b
+    let of_list =
+        let rec loop acc = function
+            | hd :: tl -> loop (replace hd acc) tl
+            | [] -> acc
         in
-        loop Z
-
-    let rec map f = function
-        | N ((key, content), color, a, b) ->
-            N ((key, f key content), color, map f a, map f b)
-        | Z ->
-            Z
-    
-    let optmap f =
-        let rec loop v = function
-            | Z ->
-                v
-            | N (pair, _, a, b) ->
-                let v =
-                    match f pair with
-                    | Some e' ->
-                        let key, _ = pair in
-                        let v, p = insert (key, e') v in
-                        assert (p = None);
-                        v
-                    | None ->
-                        v
-                in
-                loop (loop v a) b
-        in
-        loop Z
-    
-    let partition f =
-        let rec loop (v1, v2 as v) = function
-            | Z ->
-                v
-            | N (e, _, a, b) ->
-                let v =
-                    if f e then begin
-                        let v1, p = insert e v1 in
-                        assert (p = None);
-                        v1, v2
-                    end
-                    else begin
-                        let v2, p = insert e v2 in
-                        assert (p = None);
-                        v1, v2
-                    end
-                in
-                loop (loop v a) b
-        in
-        loop (Z, Z)
-
-    type 'a stack_t = ('a * 'a t) list
-    
-    let rec stack_min_ i = function
-        | N (e, _, a, b) -> stack_min_ ((e, b) :: i) a
-        | Z -> i
-    
-    let rec stack_max_ i = function
-        | N (e, _, a, b) -> stack_max_ ((e, a) :: i) b
-        | Z -> i
-
-    let rec seq_aux_ f =
-        let rec loop = function
-            | (e, s) :: tl ->
-                let tl = match s with N _ -> f tl s | Z -> tl in
-                Cf_seq.P (e, lazy (loop tl))
-            | [] ->
-                Cf_seq.Z
-        in
-        fun tree -> lazy (loop (f [] tree))
-    
-    let increasing tree = seq_aux_ stack_min_ tree
-    let decreasing tree = seq_aux_ stack_max_ tree
+        fun z ->
+            loop nil z
     
     let of_seq =
         let rec loop acc seq =
         in
         fun seq ->
             loop nil seq
+
+    type 'a stack_t = ('a * 'a node_t) list
     
-    let of_list =
-        let rec loop acc = function
-            | hd :: tl -> loop (replace hd acc) tl
-            | [] -> acc
-        in
-        fun z ->
-            loop nil z
+    let rec stack_min_ i = function
+        | Z ->
+            i
+        | R (e, a, b)
+        | B (e, a, b) ->
+            stack_min_ ((e, b) :: i) a
     
-    (*
-    let rec flow_aux_ f next =
+    let rec stack_max_ i = function
+        | Z ->
+            i
+        | R (e, a, b)
+        | B (e, a, b) ->
+            stack_max_ ((e, a) :: i) b
+
+    let to_seq_aux_ f =
         let rec loop = function
             | (e, s) :: tl ->
-                let tl = match s with N _ -> f tl s | Z -> tl in
-                Cf_flow.P (e, lazy (loop tl))
+                let tl = match s with Z -> tl | _ -> f tl s in
+                Cf_seq.P (e, lazy (loop tl))
             | [] ->
-                next
+                Cf_seq.Z
         in
-        fun tree -> loop (f [] tree)
+        fun stack u -> lazy (loop (f stack 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 increasing =
-        Cf_flow.Q (fun tree -> flow_aux_ stack_min_ increasing tree)
+    let to_seq_incr =
+        let rec loop z u =
+            match u with
+            | Z ->
+                z
+            | R (x, a, b)
+            | B (x, a, b) ->
+                loop (lazy (Cf_seq.P (x, loop z b))) a
+        in
+        fun u ->
+            loop (Lazy.lazy_from_val Cf_seq.Z) u
     
-    let rec decreasing =
-        Cf_flow.Q (fun tree -> flow_aux_ stack_max_ decreasing tree)
+    let to_seq_decr =
+        let rec loop z u =
+            match u with
+            | Z ->
+                z
+            | R (x, a, b)
+            | B (x, a, b) ->
+                loop (lazy (Cf_seq.P (x, loop z a))) b
+        in
+        fun u ->
+            loop (Lazy.lazy_from_val Cf_seq.Z) u
+    
+    let to_list_aux_ f =
+        let rec loop acc = function
+            | (e, s) :: tl ->
+                let tl = match s with Z -> tl | _ -> f tl s in
+                loop (e :: acc) tl
+            | [] ->
+                acc (* reversed *)
+        in
+        fun stack u -> loop [] (f stack u)
+
+    let to_list_incr u = to_list_aux_ stack_max_ [] u
+    let to_list_decr u = to_list_aux_ stack_min_ [] 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)) as u ->
+            let d = N.kcompare key n in
+            if d = 0 then
+                to_seq_aux_ stack_min_ w u
+            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)) as u ->
+            let d = N.kcompare key n in
+            if d = 0 then
+                to_seq_aux_ stack_max_ w u
+            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 a
+    
+    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_t
+        
+    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
+    
+    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@wetware.com>
+    
+    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
+        | 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
+
+    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 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
+            | 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
 
-(*--- End of File [ cf_rbtree.ml ] ---*)
+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_t
+    
+    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) as s ->
+            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
+                s, Some y
+            end
+        | B (y, a, b) as s ->
+            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
+                s, 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_rbt.ml ] ---*)

File cf/cf_rbtree.mli

 (*---------------------------------------------------------------------------*
-  INTERFACE  cf_rbtree.mli
+  INTERFACE  cf_rbt.mli
 
-  Copyright (c) 2002-2004, James H. Woodyatt
+  Copyright (c) 2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
 
 (** {6 Overview}
     
-    This module implements functional red-black binary trees with nodes that
-    are key-value pairs as defined by the {!Cf_ordered.KV_Pair} functor.  This
-    permits the tree to be used as an alternative to the [Map] module in the
-    Ocaml standard library.
+    This module implements functional sets and maps based on red-black binary
+    trees.  This permits trees that can be used as an alternative to the [Set]
+    and [Map] modules in the Ocaml standard library.  For many operations on
+    sets and maps, red-black binary trees give better performance that the
+    balanced trees in the standard library (though some applications may see
+    better performance with the standard modules).
 *)
 
+(** {6 Module} *)
 
-(** {6 Module Type} *)
+(** A functor that produces a module of type [Cf_set] to represent sets with
+    the element type described by [E].
+*)
+module Set(E: Cf_ordered.Total_T): Cf_set.T with module Element = E
 
-(** This is the type of modules produced by the [Create(K: Cf_ordered.Total_T)]
-    functor below.
+(** A functor that produces a module of type [Cf_map] to represent maps with
+    keys of the type described by [K].
 *)
-module type T = sig
-    (** The module defining the total order of keys in the tree. *)
-    module Key: Cf_ordered.Total_T
-    
-    (** The module defining the type of ordered pairs used as elements in the
-        tree.
-    *)
-    module Pair: Cf_ordered.KV_Pair_T with module Key = Key
-    
-    (** The tree type. *)
-    type +'a t
-    
-    (** The empty tree. *)
-    val nil: 'a t
-    
-    (** Use [empty m] to test whether the tree [m] is empty. *)
-    val empty: 'a t -> bool
-    
-    (** Use [size m] to count the number of elements in the tree [m]. *)
-    val size: 'a t -> int
-    
-    (** Use [min m] to obtain the key-value pair with the ordinally minimum key
-        in the tree [m].  Raises [Not_found] if the tree is empty.
-    *)
-    val min: 'a t -> 'a Pair.t
-    
-    (** Use [max m] to obtain the key-value pair with the ordinally maximum key
-        in the tree [m].  Raises [Not_found] if the tree is empty.
-    *)
-    val max: 'a t -> 'a Pair.t
-    
-    (** Use [search k m] to obtain the value associated with the key [k] in the
-        tree [m].  Raise [Not_found] if the tree does not contain the key.
-    *)
-    val search: Key.t -> 'a t -> 'a
-    
-    (** Use [member k m] to test whether the tree [m] contains the key [k]. *)
-    val member: Key.t -> 'a t -> bool
+module Map(K: Cf_ordered.Total_T): Cf_map.T with module Key = K
 
-    (** Use [nearest_pred k m] to obtain the key-value pair ordinally less than
-        or equal to the key [k] in the tree[m].  Raises [Not_found] if the tree
-        is empty or all the keys are ordinally greater.
-    *)
-    val nearest_pred: Key.t -> 'a t -> 'a Pair.t
-    
-    (** Use [nearest_succ k m] to obtain the key-value pair ordinally greater
-        than or equal to the key [k] in the tree[m].  Raises [Not_found] if the
-        tree is empty or all the keys are ordinally less.
-    *)
-    val nearest_succ: Key.t -> 'a t -> 'a Pair.t
-
-    (** Use [insert p m] to insert the key-value pair [p] into the tree [m],
-        producing a new tree with the inserted element and, if the key [k] is
-        already present in [m], the value replaced by the insertion.
-    *)
-    val insert: 'a Pair.t -> 'a t -> 'a t * 'a option
-    
-    (** Use [replace p m] to obtain a new tree produced by inserting the
-        key-value pair [p] into the tree [m], replacing any existing pair
-        associated to the same key.
-    *)
-    val replace: 'a Pair.t -> 'a t -> 'a t
-    
-    (** Use [modify k f m] to obtain a new tree produced by replacing the value
-        in the tree [m] associated with the key [k] with the result of applying
-        it to the continuation function [f].  Raises [Not_found] if the tree
-        does not contain the key.
-    *)
-    val modify: Key.t -> ('a -> 'a) -> 'a t -> 'a t
-    
-    (** Use [extract k m] to obtain the value associated with the key [k] in
-        the tree [m] and a new tree with the key deleted from the tree.  Raises
-        [Not_found] if the tree does not contain the key.
-    *)
-    val extract: Key.t -> 'a t -> 'a * 'a t
-    
-    (** Use [delete k m] to obtain a new tree produced by deleting the key [k]
-        from the tree [m].  If the tree does not contain the key, then the
-        function simply returns its argument.
-    *)
-    val delete: Key.t -> 'a t -> 'a t
-    
-    (** Use [iterate f m] to apply the function [f] to each key-value pair in
-        the tree [m] in an arbitrary order (not increasing or decreasing).
-    *)
-    val iterate: ('a Pair.t -> unit) -> 'a t -> unit
-    
-    (** Use [predicate f m] to test whether all the key-value pairs in the tree
-        [m] satisfy the predicate function [f].  The nodes of the tree are
-        visited in an arbitrary order (not increasing or decreasing).
-    *)
-    val predicate: ('a Pair.t -> bool) -> 'a t -> bool
-
-    (** Use [fold f s m] to fold the every key-value pair in the tree [m] into
-        the state [s] with the folding function [f], visiting the elements in
-        an arbitrary order (not increasing or decreasing).  Runs in O(log N)
-        space, i.e. not tail-recursive.
-    *)
-    val fold: ('b -> 'a Pair.t -> 'b) -> 'b -> 'a t -> 'b
-    
-    (** Use [filter f m] to obtain a new tree comprised of all the key-value
-        pairs in the tree [m] that satisfy the filtering function [f].  The
-        elements in [m] are visited in arbitrary order (not increasing or
-        decreasing).  Runs in O(log N) space, i.e. not tail-recursive.
-    *)
-    val filter: ('a Pair.t -> bool) -> 'a t -> 'a t
-    
-    (** Use [map f m] to obtain a new tree produced by applying the mapping
-        function [f] to the key and the value of each key-value pair in the
-        tree [m] and associating the resulting value to the key in the new
-        tree.  Elements in the tree are visited in arbitrary order (not
-        increasing or descreasing.  Runs in O(log N) space, i.e. not
-        tail-recursive.
-    *)
-    val map: (Key.t -> 'a -> 'b) -> 'a t -> 'b t
-    
-    (** Use [optmap f m] to obtain a new tree produced by applying the mapping
-        function [f] to the key and the value of each key-value pair in the
-        tree [m] and associating the resulting value to the key in the new
-        tree.  If the function [f] returns [None] then no value for that key
-        will be present in the new tree.  Elements in the tree are visited in
-        arbitrary order (not increasing or descreasing.  Runs in O(log N)
-        space, i.e. not tail-recursive.
-    *)
-    val optmap: ('a Pair.t -> 'b option) -> 'a t -> 'b t
-    
-    (** Use [partition f m] to obtain a pair of new trees produced by applying
-        the partitioning function [f] to all the elements in the tree [m] in an
-        arbitrary order (not increasing or descreasing).  The first tree will
-        contain all the elements for which [f] returns [true], and the second
-        tree will have all the elements for which [f] returns [false].  Runs in
-        O(log N) space, i.e. not tail-recursive.
-    *)
-    val partition: ('a Pair.t -> bool) -> 'a t -> 'a t * 'a t
-
-    (** Use [increasing m] to obtain a sequence of the key-value pairs in the
-        tree [m] in order of increasing ordinality.
-    *)
-    val increasing: 'a t -> 'a Pair.t Cf_seq.t
-
-    (** Use [descreasing m] to obtain a sequence of the key-value pairs in the
-        tree [m] in order of descreasing ordinality.
-    *)
-    val decreasing: 'a t -> 'a Pair.t Cf_seq.t
-    
-    (** Use [of_seq z] to compose a tree by evaluating the entire sequence of
-        key-value pairs [z] and inserting them in order into a new tree.
-    *)
-    val of_seq: 'a Pair.t Cf_seq.t -> 'a t
-    
-    (** Use [of_list s] to compose a tree by iterating the list of key-value
-        pairs [s] and inserting them in order into a new tree.
-    *)
-    val of_list: 'a Pair.t list -> 'a t
-end
-
-(** The functor that creates a red-black binary tree module. *)
-module Create(K: Cf_ordered.Total_T): T with module Key = K
-
-(*--- End of File [ cf_rbtree.mli ] ---*)
+(*--- End of File [ cf_rbt.mli ] ---*)

File cf/cf_sbheap.ml

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-module type T = sig
+    
+type 'a node_t = 'a tree_t list
+and 'a tree_t = N of int * 'a * 'a list * 'a node_t
+
+module type Node_T = sig
     module Key: Cf_ordered.Total_T
-    module Pair: Cf_ordered.KV_Pair_T with module Key = Key
-    
     type +'a t
-    
-    val nil: 'a t
-    val empty: 'a t -> bool
-    val size: 'a t -> int
-    
-    val head: 'a t -> 'a Pair.t
-    val tail: 'a t -> 'a t
-    val pop: 'a t -> ('a Pair.t * 'a t) option
-    val put: 'a Pair.t -> 'a t -> 'a t
-    val merge: 'a t -> 'a t -> 'a t
-    
-    val iterate: ('a Pair.t -> unit) -> 'a t -> unit
-    val predicate: ('a Pair.t -> bool) -> 'a t -> bool
-    val fold: ('b -> 'a Pair.t -> 'b) -> 'b -> 'a t -> 'b
-    val filter: ('a Pair.t -> bool) -> 'a t -> 'a t
-    val map: (Key.t -> 'a -> 'b) -> 'a t -> 'b t
-    val optmap: ('a Pair.t -> 'b option) -> 'a t -> 'b t
-    val partition: ('a Pair.t -> bool) -> 'a t -> 'a t * 'a t
-
-    val of_seq: 'a Pair.t Cf_seq.t -> 'a t
-    val of_list: 'a Pair.t list -> 'a t
-
-    val to_seq: 'a t -> 'a Pair.t Cf_seq.t
-    val to_seq2: 'a t -> ('a Pair.t * 'a t) Cf_seq.t
-
-    (* class ['a] stream: 'a t -> ['a, 'a t] Cf_stream.tailed_t *)
+    val compare: 'a t -> 'a t -> int
 end
 
-module Create(K: Cf_ordered.Total_T) : (T with module Key = K) = struct
-    module Key = K
-    module Pair = Cf_ordered.KV_Pair(Key)
-    
-    type 'a t = 'a tree_t list
-    and 'a tree_t = N of int * 'a Pair.t * 'a Pair.t list * 'a t
-    
+module Core(N: Node_T) = struct
+    module N = N
+        
     let nil = []
     let empty h = (h = [])
     
     let root_ (N (_, x, _, _)) = x
     
     let link_ t1 t2 =
-        let N (r, (x1k, _ as x1), xs1, c1) = t1
-        and N (_, (x2k, _ as x2), xs2, c2) = t2
+        let N (r, x1, xs1, c1) = t1
+        and N (_, x2, xs2, c2) = t2
         in
         let r = succ r in
-        if Key.compare x1k x2k < 0
+        if N.compare x1 x2 < 0
             then N (r, x1, xs1, t2 :: c1)
             else N (r, x2, xs2, t1 :: c2)
     
-    let skew_link_ (xk, _ as x) t1 t2 =
-        let N (r, (yk, _ as y), ys, c) = link_ t1 t2 in
-        if Key.compare xk yk < 0
+    let skew_link_ x t1 t2 =
+        let N (r, y, ys, c) = link_ t1 t2 in
+        if N.compare x y < 0
             then N (r, x, y :: ys, c)
             else N (r, y, x :: ys, c)
     
         | x :: [] -> x, []
         | hd :: tl ->
             let hd', tl' = remove_tree_ tl in
-            let hdk, _ = root_ hd in
-            let hdk', _ = root_ hd' in
-            if Key.compare hdk hdk' < 0
+            let x = root_ hd in
+            let y = root_ hd' in
+            if N.compare x y < 0
                 then hd, tl
                 else hd', hd :: tl'
     
         let g h x = if f x then put x h else h in
         fun ts -> fold g nil ts
     
-    let map f =
-        let g h (xk, xv as x) = put (xk, f xk xv) h in
-        fun ts -> fold g nil ts
-    
-    let optmap f =
-        let g h (xk, _ as x) =
-            match f x with
-            | Some y -> put (xk, y) h
-            | None -> h
-        in
-        fun ts -> fold g nil ts
-    
     let partition f =
         let g (h0, h1) x = if f x then put x h0, h1 else h0, put x h1 in
         fun ts -> fold g (nil, nil) ts
         end
 end
 
+module Heap(E: Cf_ordered.Total_T) = struct
+    include Core(struct
+        module Key = E
+        
+        type 'a t = E.t
+        
+        let compare x y = E.compare x y
+    end)
+    
+    module Element = E
+    type t = E.t node_t
+end
+
+module PQueue(K: Cf_ordered.Total_T) = struct
+    include Core(struct
+        module Key = K
+        type 'a t = Key.t * 'a
+        
+        let compare (x, _) (y, _) = Key.compare x y
+    end)
+
+    module Key = K
+    
+    type 'a t = 'a N.t node_t
+    
+    let map f =
+        let g h (k, _ as x) = put (k, f x) h in
+        fun ts -> fold g nil ts
+    
+    let optmap f =
+        let g h (k, _ as x) =
+            match f x with
+            | Some x -> put (k, x) h
+            | None -> h
+        in
+        fun ts -> fold g nil ts
+end
+
 (*--- End of File [ cf_sbheap.ml ] ---*)

File cf/cf_sbheap.mli

     have O(1) cost in space and time for most operations, including [merge].
     The underlying algorithm can be found in Chris Okasaki's
     {{:http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf}Ph.D. thesis}.
-    
-    The implementation assumes that the elements in a heap are key-value pairs
-    of the type defined by the {!Cf_ordered.KV_Pair} functor.  This permits the
-    heap to be used as a functional priority queue.
 *)
 
-(** {6 Module Type} *)
+(** {6 Modules} *)
 
-(** This is the type of modules produced by the [Create(K: Cf_ordered.Total_T)]
-    functor below.
+(** A functor that produces a module of type [Cf_heap] to represent heaps with
+    the element type described by [E].
 *)
-module type T = sig
-    (** The module defining the total order of keys in the heap. *)
-    module Key: Cf_ordered.Total_T
-    
-    (** The module defining the type of ordered pairs used as elements in the
-        heap.
-    *)
-    module Pair: Cf_ordered.KV_Pair_T with module Key = Key
-    
-    (** The heap type. *)
-    type +'a t
-    
-    (** The empty heap. *)
-    val nil: 'a t
-    
-    (** Use [empty h] to test whether the heap [h] is empty. *)
-    val empty: 'a t -> bool
-    
-    (** Use [size h] to count the number of elements in the heap [h].  Runs
-        in O(n) time and O(log N) space.
-    *)
-    val size: 'a t -> int
-    
-    (** Use [head h] to obtain the ordered pair on the top of the heap [h].
-        Raises [Not_found] if the heap is empty.
-    *)
-    val head: 'a t -> 'a Pair.t
-    
-    (** Use [tail h] to obtain the heap produced by discarding the ordered pair
-        on the top of heap [h].  If [h] is the empty heap, then the empty heap
-        is returned.
-    *)
-    val tail: 'a t -> 'a t
-    
-    (** Use [pop h] to obtain the head and the tail of a heap [h] in one
-        operation.  Returns [None] if the [h] is empty.
-    *)
-    val pop: 'a t -> ('a Pair.t * 'a t) option
-    
-    (** Use [put (k, v) h] to obtain a new heap that is the result of inserting
-        the ordered pair with the key [k] and the value [v] into the heap [h].
-    *)
-    val put: 'a Pair.t -> 'a t -> 'a t
-    
-    (** Use [merge h1 h2] to obtain a new heap that is the result of merging
-        all the elements of [h1] and [h2] into a single heap.
-    *)
-    val merge: 'a t -> 'a t -> 'a t
+module Heap(E: Cf_ordered.Total_T): Cf_heap.T with module Element = E
 
-    (** Use [iterate f h] to apply [f] to every element in the heap [h] in an
-        arbitrary order (not top to bottom).  Runs in O(n) time and O(1) space.
-    *)
-    val iterate: ('a Pair.t -> unit) -> 'a t -> unit
-    
-    (** Use [predicate f h] to test whether all the elements in heap [h]
-        satisfy the predicate function [f].  Runs in O(n) time (with a short
-        cut when an element is found to fail the predicate) and O(1) space.
-        Visits the elements in the heap in arbitrary order (not top to bottom).
-    *)
-    val predicate: ('a Pair.t -> bool) -> 'a t -> bool
-    
-    (** Use [fold f s h] to produce the result of folding a value [s] into
-        the elements of heap [h] with the folding function [f] in an arbitrary
-        order (not top to bottom).  Runs in O(n) time and O(1) space.
-    *)
-    val fold: ('b -> 'a Pair.t -> 'b) -> 'b -> 'a t -> 'b
-    
-    (** Use [filter f h] to apply [f] to each element in the heap [h] in an
-        arbitrary order (not to top bottom), and produce a new heap that
-        contains only those elements for which [f pair] returned [true].
-    *)
-    val filter: ('a Pair.t -> bool) -> 'a t -> 'a t
-    
-    (** Use [map f h] to obtain a new heap by applying the mapping function [f]
-        to the key and the value of every element in heap [h] to obtain a
-        mapped element with the same key and a new value.  The elements of [h]
-        are visited in an arbitrary order (not top to bottom).  Runs in O(n)
-        time and O(log N) space.
-    *)
-    val map: (Key.t -> 'a -> 'b) -> 'a t -> 'b t
-    
-    (** Use [optmap f h] to obtain a new heap by applying the mapping function
-        [f] to the key and the value of every element in heap [h] to obtain a
-        mapped element with the same key and a new value.  The elements of [h]
-        are visited in an arbitrary order (not top to bottom).  When [f]
-        returns [None] for a given key, that key will not be present in the new
-        heap.  Runs in O(n) time and O(1) space.
-    *)
-    val optmap: ('a Pair.t -> 'b option) -> 'a t -> 'b t
-    
-    (** Use [partition f h] to obtain a pair of new heaps that are the result
-        of applying the partitioning function [f] to each element in the heap
-        [h] in an arbitrary order (not top to bottom).  The first heap returned
-        will contain all the elements for which [f pair] returned true, and the
-        second heap will return all the remaining elements.
-    *)
-    val partition: ('a Pair.t -> bool) -> 'a t -> 'a t * 'a t
-
-    (** Use [of_seq z] to construct a heap from a sequence of key-value pairs.
-        Evaluates the whole sequence.  Runs in O(n) time and O(1) space.
-    *)
-    val of_seq: 'a Pair.t Cf_seq.t -> 'a t
-    
-    (** Use [of_list s] to construct a heap from a list of key-value pairs.
-        Runs in O(n) time and O(1) space.
-    *)
-    val of_list: 'a Pair.t list -> 'a t
-    
-    (** Use [to_seq h] to produce a sequence of key-value pairs in top to
-        bottom order from the heap [h].
-    *)
-    val to_seq: 'a t -> 'a Pair.t Cf_seq.t
-    
-    (** Use [to_seq2 h] to produce a sequence of ordered pairs from the heap
-        [h] where the first element of each pair is a key-value pair obtained
-        from the head of the heap, and the second element of the pair is the
-        corresponding tail of the heap.
-    *)
-    val to_seq2: 'a t -> ('a Pair.t * 'a t) Cf_seq.t
-end
-
-(** The functor that creates a skew binomial heap module. *)
-module Create(K: Cf_ordered.Total_T): T with module Key = K
+(** A functor that produces a module of type [Cf_pqueue] to represent priority
+    queues with keys of the type described by [K].
+*)
+module PQueue(K: Cf_ordered.Total_T): Cf_pqueue.T with module Key = K
 
 (*--- End of File [ cf_sbheap.mli ] ---*)

File cf/cf_seq.ml

     | P (hd, tl) -> f hd && predicate f tl
     | Z -> true
 
+let rec constrain f s =
+    lazy begin
+        match Lazy.force s with
+        | P (hd, tl) when f hd -> P (hd, constrain f tl)
+        | _ -> Z
+    end
+
 let search f =
     let rec loop n s =
         match Lazy.force s with
     | Z, Z -> true
     | _, _ -> false
 
+let rec constrain2 f s0 s1 =
+    lazy begin
+        match Lazy.force s0, Lazy.force s1 with
+        | P (hd1, tl1), P (hd2, tl2) when f hd1 hd2 ->
+            P ((hd1, hd2), constrain2 f tl1 tl2)
+        | _, _ ->
+            Z
+    end
+
 let rec fold2 f m s0 s1 =
     match Lazy.force s0, Lazy.force s1 with
     | P (hd1, tl1), P (hd2, tl2) -> fold2 f (f m hd1 hd2) tl1 tl2

File cf/cf_seq.mli

 *)
 val predicate: ('a -> bool) -> 'a t -> bool
 
-(** [search f s] evaluates the sequence [s] until the result of applying
-    [f] is [true] and returns the number of elements applied that resulted in
-    a [false] result.  Tail recursive.
+(** [constrain f s] evaluates the sequence [s] by applying [f] to each element
+    while the result is [true].  The returned sequence is all the elements of
+    [s] before the first element for which [f] returns false.  Tail recursive.
+*)
+val constrain: ('a -> bool) -> 'a t -> 'a t
+
+(** [search f s] evaluates the sequence [s] until the result of applying [f] is
+    [true] and returns the number of elements applied that resulted in a
+    [false] result.  Tail recursive.
 *)
 val search: ('a -> bool) -> 'a t -> int
 
 *)
 val predicate2: ('a -> 'b -> bool) -> 'a t -> 'b t -> bool
 
+(** [constrain2 f a b] is like [constrain f s], except it operates on a pair of
+    sequences simultaneously, until one or both sequences reaches its end or
+    the constrain returns [false].
+*)
+val constrain2: ('a -> 'b -> bool) -> 'a t -> 'b t -> ('a * 'b) t
+
 (** [fold2 f a s1 s2] is like [fold f a s], except it operates on a pair of
     sequences simultaneously, until one or both sequences reaches its end.
 *)

File cf/cf_set.ml

 (*---------------------------------------------------------------------------*
   IMPLEMENTATION  cf_set.ml
 
-  Copyright (c) 2002-2004, James H. Woodyatt
+  Copyright (c) 2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
  *---------------------------------------------------------------------------*)
 
 module type T = sig
-    module Element: Cf_ordered.Total_T
-    module Tree: Cf_rbtree.T with module Key = Element
+    type t
 
-    type t
-    
-    val null: t
+    module Element: sig type t end
+        
+    val nil: t
     val empty: t -> bool
     val member: Element.t -> t -> bool
+    
     val singleton: Element.t -> t
-    
+
     val min: t -> Element.t
     val max: t -> Element.t
     
     val put: Element.t -> t -> t
     val clear: Element.t -> t -> t
-    
+
     val union: t -> t -> t
     val diff: t -> t -> t
     val intersect: t -> t -> t
-    
     val compare: t -> t -> int
     val subset: t -> t -> bool
-        
-    val elements: t -> Element.t list
+    
+    val of_seq: Element.t Cf_seq.t -> t
+    val of_list: Element.t list -> t
+    
+    val to_seq_incr: t -> Element.t Cf_seq.t
+    val to_seq_decr: t -> Element.t Cf_seq.t
+    
+    val to_list_incr: t -> Element.t list
+    val to_list_decr: t -> Element.t list
+
+    val nearest_decr: Element.t -> t -> Element.t Cf_seq.t
+    val nearest_incr: Element.t -> t -> Element.t Cf_seq.t
     
     val iterate: (Element.t -> unit) -> t -> unit
     val predicate: (Element.t -> bool) -> t -> bool
     val fold: ('a -> Element.t -> 'a) -> 'a -> t -> 'a
     val filter: (Element.t -> bool) -> t -> t
     val partition: (Element.t -> bool) -> t -> t * t
-
-    val increasing: t -> Element.t Cf_seq.t
-    val decreasing: t -> Element.t Cf_seq.t
-    
-    val of_seq: Element.t Cf_seq.t -> t
-    val of_list: Element.t list -> t
-end
-
-module Create(E: Cf_ordered.Total_T) : (T with module Element = E) = struct
-    open Cf_flow.Op
-    
-    module Element = E
-    
-    module Tree = Cf_rbtree.Create(Element)
-    type t = unit Tree.t
-    
-    let null = Tree.nil    
-    let empty = Tree.empty
-    let member = Tree.member
-    
-    let min s = let c, () = Tree.min s in c
-    let max s = let c, () = Tree.max s in c
-            
-    let singleton x =
-        let s, y = Tree.insert (x, ()) null in
-        assert (y = None);
-        s
-        
-    let put_cell_ s c = Tree.replace c s
-    
-    let put x s = put_cell_ s (x, ())
-        
-    let clear x s = Tree.delete x s
-
-    let clear_cell_ s (x, ()) = Tree.delete x s
-        
-    let union s0 s1 = Tree.fold put_cell_ s0 s1
-    let diff s0 s1 = Tree.fold clear_cell_ s0 s1
-    
-    let cell_compare_ (c0, ()) (c1, ()) = Element.compare c0 c1
-    let cell_lessthan_ c0 c1 = cell_compare_ c0 c1 < 0
-    
-    let cell_filter_ c r = Cf_seq.filter (cell_lessthan_ c) r
-
-    let intersect =
-        let rec loop s r1 r2 =
-            match Lazy.force r1, Lazy.force r2 with
-            | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) ->
-                let d = cell_compare_ hd1 hd2 in
-                if d < 0 then begin
-                    match Lazy.force (cell_filter_ hd2 tl1) with
-                    | Cf_seq.P (hd1, tl1) -> next hd1 s tl1 tl2
-                    | Cf_seq.Z -> s
-                end
-                else if d > 0 then begin
-                    match Lazy.force (cell_filter_ hd1 tl2) with
-                    | Cf_seq.P (hd2, tl2) -> next hd2 s tl1 tl2
-                    | Cf_seq.Z -> s
-                end
-                else
-                    next hd1 s tl1 tl2
-            | _, _ ->
-                s
-        and next e s r1 r2 =
-            let s, y = Tree.insert e s in
-            assert (y = None);
-            loop s r1 r2
-        in
-        fun s1 s2 ->
-            loop null (Tree.increasing s1) (Tree.increasing s2)
-    
-    let compare s0 s1 =
-        let r0 = Tree.increasing s0 and r1 = Tree.increasing s1 in
-        Cf_seq.fcmp cell_compare_ r0 r1
-    
-    let subset =
-        let rec loop r1 r2 =
-            match Lazy.force r1, Lazy.force r2 with
-            | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) ->
-                let d = cell_compare_ hd1 hd2 in
-                if d < 0 then
-                    false
-                else if d > 0 then begin
-                    match Lazy.force (cell_filter_ hd2 tl1) with
-                    | Cf_seq.P (hd1, tl1) -> loop tl1 tl2
-                    | Cf_seq.Z -> false
-                end
-                else
-                    loop tl1 tl2
-            | _, _ ->
-                true
-        in
-        fun s1 s2 ->
-            loop (Tree.increasing s1) (Tree.increasing s2)
-    
-    let returnKey_ (key, ()) = key
-    let returnPair_ key = key, ()
-    let applyKey_ f (key, ()) = f key
-        
-    let iterate f = Tree.iterate (applyKey_ f)
-    let predicate f = Tree.predicate (applyKey_ f)
-    let fold f = Tree.fold (fun x (key, ()) -> f x key)
-    let filter f = Tree.filter (fun (key, ()) -> f key)
-    let partition f = Tree.partition (applyKey_ f)
-        
-    let increasing s = Cf_seq.map returnKey_ (Tree.increasing s)
-    let decreasing s = Cf_seq.map returnKey_ (Tree.decreasing s)
-    
-    let of_seq z = Tree.of_seq (Cf_seq.map returnPair_ z)
-    let of_list s = Tree.of_seq (Cf_seq.map returnPair_ (Cf_seq.of_list s))
-    
-    let elements s = Cf_seq.reverse (decreasing s)
 end
 
 (*--- End of File [ cf_set.ml ] ---*)

File cf/cf_set.mli

 (*---------------------------------------------------------------------------*
   INTERFACE  cf_set.mli
 
-  Copyright (c) 2002-2004, James H. Woodyatt
+  Copyright (c) 2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-(** Sets over ordered types. *)
+(** A module type for functional set implementations (with enhancements over
+    the {!Set} module in the standard library).
+*)
 
 (** {6 Overview}
 
-    This module is an alternative implementation of sets over ordered types
-    using the {!Cf_rbtree} module for its underlying binary tree (instead of
-    the less efficient strictly balanced tree behind the ones in the
-    Objective Caml standard library).  It does not use precisely the same
-    module signature as the one in the standard library, but many of the
-    functions are semantically equivalent.
+    This module defines the common interface to the various implementations of
+    functional sets in the {!Cf} library.
 *)
 
-(** {6 Module Type} *)
-
-(** This is the type of modules produced by the [Create(K: Cf_ordered.Total_T)]
-    functor below.
-*)
 module type T = sig
-    (** The module defining the total order of elements in the set. *)
-    module Element: Cf_ordered.Total_T