updated CCLeftistheap with a brand new functorial interface,

with more conversion functions, etc.

core/CCLeftistheap.ml

@@ -25,156 +25,216 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (** {1 Leftist Heaps} *)
 
-(** Polymorphic implementation, following Okasaki *)
-
 type 'a sequence = ('a -> unit) -> unit
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
 type 'a gen = unit -> 'a option
+type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list]
 
-type 'a t = {
+module type PARTIAL_ORD = sig
-  tree : 'a tree;
+  type t
-  leq : 'a -> 'a -> bool;
+  val leq : t -> t -> bool
-} (** Empty heap. The function is used to check whether
+  (** [leq x y] shall return [true] iff [x] is lower or equal to [y] *)
-      the first element is smaller than the second. *)
+end
-and 'a tree =
-  | Empty
-  | Node of int * 'a * 'a tree * 'a tree
 
-let empty_with ~leq =
+module type S = sig
-  { tree = Empty;
+  type elt
-    leq;
+  type t
-  }
 
-let empty =
+  val empty : t
-  { tree = Empty;
+  (** Empty heap *)
-    leq = (fun x y -> x <= y);
-  }
 
-let is_empty heap =
+  val is_empty : t -> bool
-  match heap.tree with
+  (** Is the heap empty? *)
-  | Empty -> true
-  | _ -> false
 
-(** Rank of the tree *)
+  exception Empty
-let rank_tree t = match t with
-  | Empty -> 0
-  | Node (r, _, _, _) -> r
 
-(** Make a balanced node labelled with [x], and subtrees [a] and [b] *)
+  val merge : t -> t -> t
-let make_node x a b =
+  (** Merge two heaps *)
-  if rank_tree a >= rank_tree b
-    then Node (rank_tree b + 1, x, a, b)
-    else Node (rank_tree a + 1, x, b, a)
 
-let rec merge_tree leq t1 t2 =
+  val insert : elt -> t -> t
+  (** Insert a value in the heap *)
+
+  val add : t -> elt -> t
+  (** Synonym to {!insert} *)
+
+  val filter :  (elt -> bool) -> t -> t
+  (** Filter values, only retaining the ones that satisfy the predicate.
+      Linear time at least. *)
+
+  val find_min : t -> elt option
+  (** Find minimal element *)
+
+  val find_min_exn : t -> elt
+  (** Same as {!find_min} but can fail
+      @raise Empty if the heap is empty *)
+
+  val take : t -> (t * elt) option
+  (** Extract and return the minimum element, and the new heap (without
+      this element), or [None] if the heap is empty *)
+
+  val take_exn : t -> t * elt
+  (** Same as {!take}, but can fail.
+      @raise Empty if the heap is empty *)
+
+  val iter : (elt -> unit) -> t -> unit
+  (** Iterate on elements *)
+
+  val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a
+  (** Fold on all values *)
+
+  val size : t -> int
+  (** Number of elements (linear complexity) *)
+
+  (** {2 Conversions} *)
+
+  val to_list : t -> elt list
+  val of_list : elt list -> t
+
+  val of_seq : t -> elt sequence -> t
+  val to_seq : t -> elt sequence
+
+  val of_klist : t -> elt klist -> t
+  val to_klist : t -> elt klist
+
+  val of_gen : t -> elt gen -> t
+  val to_gen : t -> elt gen
+
+  val to_tree : t -> elt tree
+end
+
+module Make(E : PARTIAL_ORD) = struct
+  type elt = E.t
+
+  type t =
+    | E
+    | N of int * elt * t * t
+
+  let empty = E
+
+  let is_empty = function
+    | E -> true
+    | N _ -> false
+
+  exception Empty
+
+  (* Rank of the tree *)
+  let _rank = function
+    | E -> 0
+    | N (r, _, _, _) -> r
+
+  (* Make a balanced node labelled with [x], and subtrees [a] and [b].
+    We ensure that the right child's rank is ≤ to the rank of the
+    left child (leftist property). The rank of the resulting node
+    is the length of the rightmost path. *)
+  let _make_node x a b =
+    if _rank a >= _rank b
+      then N (_rank b + 1, x, a, b)
+      else N (_rank a + 1, x, b, a)
+
+  let rec merge t1 t2 =
     match t1, t2 with
-  | t, Empty -> t
+    | t, E -> t
-  | Empty, t -> t
+    | E, t -> t
-  | Node (_, x, a1, b1), Node (_, y, a2, b2) ->
+    | N (_, x, a1, b1), N (_, y, a2, b2) ->
-    if leq x y
+      if E.leq x y
-      then make_node x a1 (merge_tree leq b1 t2)
+        then _make_node x a1 (merge b1 t2)
-      else make_node y a2 (merge_tree leq t1 b2)
+        else _make_node y a2 (merge t1 b2)
 
-let merge h1 h2 =
+  let insert x h =
-  let tree = merge_tree h1.leq h1.tree h2.tree in
+    merge (N(1,x,E,E)) h
-  { tree; leq=h1.leq; }
 
-let insert heap x =
+  let add h x = insert x h
-  let tree = merge_tree heap.leq (Node (1, x, Empty, Empty)) heap.tree in
-  { heap with tree; }
 
-let add = insert
+  let rec filter p h = match h with
+    | E -> E
+    | N(_, x, l, r) when p x -> _make_node x (filter p l) (filter p r)
+    | N(_, _, l, r) ->
+        merge (filter p l) (filter p r)
 
-let filter heap p =
+  let find_min_exn = function
-  let rec filter tree p = match tree with
+    | E -> raise Empty
-  | Empty -> Empty
+    | N (_, x, _, _) -> x
-  | Node (_, x, l, r) when p x ->
-    merge_tree heap.leq (Node (1, x, Empty, Empty))
-      (merge_tree heap.leq (filter l p) (filter r p))
-  | Node (_, _, l, r) -> merge_tree heap.leq (filter l p) (filter r p)
-  in
-  { heap with tree = filter heap.tree p; }
 
-let find_min heap =
+  let find_min = function
-  match heap.tree with
+    | E -> None
-  | Empty -> raise Not_found
+    | N (_, x, _, _) -> Some x
-  | Node (_, x, _, _) -> x
 
-let extract_min heap =
+  let take = function
-  match heap.tree with
+    | E -> None
-  | Empty -> raise Not_found
+    | N (_, x, l, r) -> Some (merge l r, x)
-  | Node (_, x, a, b) ->
-    let tree = merge_tree heap.leq a b in
-    let heap' = { heap with tree; } in
-    heap', x
 
-let take heap = match heap.tree with
+  let take_exn = function
-  | Empty -> None
+    | E -> raise Empty
-  | Node (_, x, a, b) ->
+    | N (_, x, l, r) -> merge l r, x
-    let tree = merge_tree heap.leq a b in
-    let heap' = { heap with tree; } in
-    Some (x, heap')
 
-let iter f heap =
+  let rec iter f h = match h with
-  let rec iter t = match t with
+    | E -> ()
-    | Empty -> ()
+    | N(_,x,l,r) -> f x; iter f l; iter f r
-    | Node (_, x, a, b) ->
-      f x;
-      iter a;
-      iter b;
-  in iter heap.tree
 
-let fold f acc h =
+  let rec fold f acc h = match h with
-  let rec fold acc h = match h with
+    | E -> acc
-    | Empty -> acc
+    | N (_, x, a, b) ->
-    | Node (_, x, a, b) ->
         let acc = f acc x in
-        let acc = fold acc a in
+        let acc = fold f acc a in
-        fold acc b
+        fold f acc b
-  in fold acc h.tree
 
-let size heap =
+  let rec size = function
-  let r = ref 0 in
+    | E -> 0
-  iter (fun _ -> incr r) heap;
+    | N (_,_,l,r) -> 1 + size l + size r
-  !r
 
-let of_seq heap seq =
+  (** {2 Conversions} *)
-  let h = ref heap in
+
-  seq (fun x -> h := insert !h x);
+  let to_list h =
+    let rec aux acc h = match h with
+      | E -> acc
+      | N(_,x,l,r) ->
+          x::aux (aux acc l) r
+    in aux [] h
+
+  let of_list l = List.fold_left add empty l
+
+  let of_seq h seq =
+    let h = ref h in
+    seq (fun x -> h := insert x !h);
     !h
 
-let to_seq h k = iter k h
+  let to_seq h k = iter k h
 
-let rec of_klist h l = match l() with
+  let rec of_klist h l = match l() with
     | `Nil -> h
     | `Cons (x, l') ->
         let h' = add h x in
         of_klist h' l'
 
-let to_klist h =
+  let to_klist h =
     let rec next stack () = match stack with
       | [] -> `Nil
-    | Empty :: stack' -> next stack' ()
+      | E :: stack' -> next stack' ()
-    | Node (_, x, a, b) :: stack' ->
+      | N (_, x, a, b) :: stack' ->
           `Cons (x, next (a :: b :: stack'))
     in
-  next [h.tree]
+    next [h]
 
-let rec of_gen h g = match g () with
+  let rec of_gen h g = match g () with
     | None -> h
     | Some x ->
         of_gen (add h x) g
 
-let to_gen h =
+  let to_gen h =
     let stack = Stack.create () in
-  Stack.push h.tree stack;
+    Stack.push h stack;
     let rec next () =
       if Stack.is_empty stack
       then None
       else match Stack.pop stack with
-      | Empty -> next()
+        | E -> next()
-      | Node (_, x, a, b) ->
+        | N (_, x, a, b) ->
             Stack.push a stack;
             Stack.push b stack;
             Some x
     in next
+
+  let rec to_tree h () = match h with
+    | E -> `Nil
+    | N (_, x, l, r) -> `Node(x, [to_tree l; to_tree r])
+end

core/CCLeftistheap.mli

@@ -23,65 +23,83 @@ 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.
 *)
 
-(** {1 Leftist Heaps}
+(** {1 Leftist Heaps} following Okasaki *)
-Polymorphic implementation, following Okasaki *)
 
 type 'a sequence = ('a -> unit) -> unit
 type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist]
+type 'a tree = unit -> [`Nil | `Node of 'a * 'a tree list]
 type 'a gen = unit -> 'a option
 
-type 'a t
+module type PARTIAL_ORD = sig
-  (** Heap containing values of type 'a *)
+  type t
+  val leq : t -> t -> bool
+  (** [leq x y] shall return [true] iff [x] is lower or equal to [y] *)
+end
 
-val empty_with : leq:('a -> 'a -> bool) -> 'a t
+module type S = sig
-  (** Empty heap. The function is used to check whether the first element is
+  type elt
-      smaller than the second. *)
+  type t
 
-val empty : 'a t
+  val empty : t
-  (** Empty heap using [Pervasives.compare] *)
+  (** Empty heap *)
 
-val is_empty : _ t -> bool
+  val is_empty : t -> bool
   (** Is the heap empty? *)
 
-val merge : 'a t -> 'a t -> 'a t
+  exception Empty
-  (** Merge two heaps (assume they have the same comparison function) *)
 
-val insert : 'a t -> 'a -> 'a t
+  val merge : t -> t -> t
+  (** Merge two heaps *)
+
+  val insert : elt -> t -> t
   (** Insert a value in the heap *)
 
-val add : 'a t -> 'a -> 'a t
+  val add : t -> elt -> t
   (** Synonym to {!insert} *)
 
-val filter : 'a t -> ('a -> bool) -> 'a t
+  val filter :  (elt -> bool) -> t -> t
   (** Filter values, only retaining the ones that satisfy the predicate.
       Linear time at least. *)
 
-val find_min : 'a t -> 'a
+  val find_min : t -> elt option
-  (** Find minimal element, or fails
+  (** Find minimal element *)
-      @raise Not_found if the heap is empty *)
 
-val extract_min : 'a t -> 'a t * 'a
+  val find_min_exn : t -> elt
-  (** Extract and returns the minimal element, or
+  (** Same as {!find_min} but can fail
-      raise Not_found if the heap is empty *)
+      @raise Empty if the heap is empty *)
 
-val take : 'a t -> ('a * 'a t) option
+  val take : t -> (t * elt) option
   (** Extract and return the minimum element, and the new heap (without
       this element), or [None] if the heap is empty *)
 
-val iter : ('a -> unit) -> 'a t -> unit
+  val take_exn : t -> t * elt
+  (** Same as {!take}, but can fail.
+      @raise Empty if the heap is empty *)
+
+  val iter : (elt -> unit) -> t -> unit
   (** Iterate on elements *)
 
-val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
+  val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a
   (** Fold on all values *)
 
-val size : _ t -> int
+  val size : t -> int
   (** Number of elements (linear complexity) *)
 
-val of_seq : 'a t -> 'a sequence -> 'a t
+  (** {2 Conversions} *)
-val to_seq : 'a t -> 'a sequence
 
-val of_klist : 'a t -> 'a klist -> 'a t
+  val to_list : t -> elt list
-val to_klist : 'a t -> 'a klist
+  val of_list : elt list -> t
 
-val of_gen : 'a t -> 'a gen -> 'a t
+  val of_seq : t -> elt sequence -> t
-val to_gen : 'a t -> 'a gen
+  val to_seq : t -> elt sequence
+
+  val of_klist : t -> elt klist -> t
+  val to_klist : t -> elt klist
+
+  val of_gen : t -> elt gen -> t
+  val to_gen : t -> elt gen
+
+  val to_tree : t -> elt tree
+end
+
+module Make(E : PARTIAL_ORD) : S with type elt = E.t

tests/test_leftistheap.ml

@@ -3,26 +3,27 @@
 
 open OUnit
 
-module Leftistheap = CCLeftistheap
 module Sequence = CCSequence
 
-let empty = Leftistheap.empty
+module H = CCLeftistheap.Make(struct type t = int let leq x y =x<=y end)
+
+let empty = H.empty
 
 let test1 () =
-  let h = Leftistheap.of_seq empty (Sequence.of_list [5;3;4;1;42;0]) in
+  let h = H.of_list [5;3;4;1;42;0] in
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 0 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 1 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 3 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 4 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 5 x;
-  let h, x = Leftistheap.extract_min h in
+  let h, x = H.take_exn h in
   OUnit.assert_equal ~printer:string_of_int 42 x;
-  OUnit.assert_raises Not_found (fun () -> Leftistheap.extract_min h);
+  OUnit.assert_raises H.Empty (fun () -> H.take_exn h);
   ()
 
 let rec is_sorted l = match l with
@@ -33,10 +34,10 @@ let rec is_sorted l = match l with
 (* extract the content of the heap into a list *)
 let extract_list heap =
   let rec recurse acc h =
-    if Leftistheap.is_empty h
+    if H.is_empty h
       then List.rev acc
       else
-        let h', x = Leftistheap.extract_min h in
+        let h', x = H.take_exn h in
         recurse (x::acc) h'
   in
   recurse [] heap
@@ -46,8 +47,8 @@ let test_sort () =
   let n = 100_000 in
   let l = Sequence.to_rev_list (Sequence.take n (Sequence.random_int n)) in
   (* put elements into a heap *)
-  let h = Leftistheap.of_seq empty (Sequence.of_list l) in
+  let h = H.of_seq empty (Sequence.of_list l) in
-  OUnit.assert_equal n (Leftistheap.size h);
+  OUnit.assert_equal n (H.size h);
   let l' = extract_list h in
   OUnit.assert_bool "sorted" (is_sorted l');
   ()