From cac3500177a056bcdcef45d01730a1074ca6d54e Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Wed, 25 Jun 2014 01:27:43 +0200
Subject: [PATCH] updated CCLeftistheap with a brand new functorial interface,
 with more conversion functions, etc.

---
 core/CCLeftistheap.ml     | 312 +++++++++++++++++++++++---------------
 core/CCLeftistheap.mli    |  80 ++++++----
 tests/test_leftistheap.ml |  29 ++--
 3 files changed, 250 insertions(+), 171 deletions(-)

diff --git a/core/CCLeftistheap.ml b/core/CCLeftistheap.ml
index 1a73853c..b3464cf1 100644
--- a/core/CCLeftistheap.ml
+++ b/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 = {
-  tree : 'a tree;
-  leq : 'a -> 'a -> bool;
-} (** Empty heap. The function is used to check whether
-      the first element is smaller than the second. *)
-and 'a tree =
-  | Empty
-  | Node of int * 'a * 'a tree * 'a tree
+module type PARTIAL_ORD = sig
+  type t
+  val leq : t -> t -> bool
+  (** [leq x y] shall return [true] iff [x] is lower or equal to [y] *)
+end
 
-let empty_with ~leq =
-  { tree = Empty;
-    leq;
-  }
+module type S = sig
+  type elt
+  type t
 
-let empty =
-  { tree = Empty;
-    leq = (fun x y -> x <= y);
-  }
+  val empty : t
+  (** Empty heap *)
 
-let is_empty heap =
-  match heap.tree with
-  | Empty -> true
-  | _ -> false
+  val is_empty : t -> bool
+  (** Is the heap empty? *)
 
-(** Rank of the tree *)
-let rank_tree t = match t with
-  | Empty -> 0
-  | Node (r, _, _, _) -> r
+  exception Empty
 
-(** Make a balanced node labelled with [x], and subtrees [a] and [b] *)
-let make_node x a b =
-  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)
+  val merge : t -> t -> t
+  (** Merge two heaps *)
 
-let rec merge_tree leq t1 t2 =
-  match t1, t2 with
-  | t, Empty -> t
-  | Empty, t -> t
-  | Node (_, x, a1, b1), Node (_, y, a2, b2) ->
-    if leq x y
-      then make_node x a1 (merge_tree leq b1 t2)
-      else make_node y a2 (merge_tree leq t1 b2)
+  val insert : elt -> t -> t
+  (** Insert a value in the heap *)
 
-let merge h1 h2 =
-  let tree = merge_tree h1.leq h1.tree h2.tree in
-  { tree; leq=h1.leq; }
+  val add : t -> elt -> t
+  (** Synonym to {!insert} *)
 
-let insert heap x =
-  let tree = merge_tree heap.leq (Node (1, x, Empty, Empty)) heap.tree in
-  { heap with tree; }
+  val filter :  (elt -> bool) -> t -> t
+  (** Filter values, only retaining the ones that satisfy the predicate.
+      Linear time at least. *)
 
-let add = insert
+  val find_min : t -> elt option
+  (** Find minimal element *)
 
-let filter heap p =
-  let rec filter tree p = match tree with
-  | Empty -> Empty
-  | 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; }
+  val find_min_exn : t -> elt
+  (** Same as {!find_min} but can fail
+      @raise Empty if the heap is empty *)
 
-let find_min heap =
-  match heap.tree with
-  | Empty -> raise Not_found
-  | Node (_, x, _, _) -> x
+  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 *)
 
-let extract_min heap =
-  match heap.tree with
-  | Empty -> raise Not_found
-  | Node (_, x, a, b) ->
-    let tree = merge_tree heap.leq a b in
-    let heap' = { heap with tree; } in
-    heap', x
+  val take_exn : t -> t * elt
+  (** Same as {!take}, but can fail.
+      @raise Empty if the heap is empty *)
 
-let take heap = match heap.tree with
-  | Empty -> None
-  | Node (_, x, a, b) ->
-    let tree = merge_tree heap.leq a b in
-    let heap' = { heap with tree; } in
-    Some (x, heap')
+  val iter : (elt -> unit) -> t -> unit
+  (** Iterate on elements *)
 
-let iter f heap =
-  let rec iter t = match t with
-    | Empty -> ()
-    | Node (_, x, a, b) ->
-      f x;
-      iter a;
-      iter b;
-  in iter heap.tree
+  val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a
+  (** Fold on all values *)
 
-let fold f acc h =
-  let rec fold acc h = match h with
-    | Empty -> acc
-    | Node (_, x, a, b) ->
+  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, E -> t
+    | E, t -> t
+    | N (_, x, a1, b1), N (_, y, a2, b2) ->
+      if E.leq x y
+        then _make_node x a1 (merge b1 t2)
+        else _make_node y a2 (merge t1 b2)
+
+  let insert x h =
+    merge (N(1,x,E,E)) h
+
+  let add h x = insert x h
+
+  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 find_min_exn = function
+    | E -> raise Empty
+    | N (_, x, _, _) -> x
+
+  let find_min = function
+    | E -> None
+    | N (_, x, _, _) -> Some x
+
+  let take = function
+    | E -> None
+    | N (_, x, l, r) -> Some (merge l r, x)
+
+  let take_exn = function
+    | E -> raise Empty
+    | N (_, x, l, r) -> merge l r, x
+
+  let rec iter f h = match h with
+    | E -> ()
+    | N(_,x,l,r) -> f x; iter f l; iter f r
+
+  let rec fold f acc h = match h with
+    | E -> acc
+    | N (_, x, a, b) ->
         let acc = f acc x in
-        let acc = fold acc a in
-        fold acc b
-  in fold acc h.tree
+        let acc = fold f acc a in
+        fold f acc b
 
-let size heap =
-  let r = ref 0 in
-  iter (fun _ -> incr r) heap;
-  !r
+  let rec size = function
+    | E -> 0
+    | N (_,_,l,r) -> 1 + size l + size r
 
-let of_seq heap seq =
-  let h = ref heap in
-  seq (fun x -> h := insert !h x);
-  !h
+  (** {2 Conversions} *)
 
-let to_seq h k = iter k h
+  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 rec of_klist h l = match l() with
-  | `Nil -> h
-  | `Cons (x, l') ->
-      let h' = add h x in
-      of_klist h' l'
+  let of_list l = List.fold_left add empty l
 
-let to_klist h =
-  let rec next stack () = match stack with
-    | [] -> `Nil
-    | Empty :: stack' -> next stack' ()
-    | Node (_, x, a, b) :: stack' ->
-        `Cons (x, next (a :: b :: stack'))
-  in
-  next [h.tree]
+  let of_seq h seq =
+    let h = ref h in
+    seq (fun x -> h := insert x !h);
+    !h
 
-let rec of_gen h g = match g () with
-  | None -> h
-  | Some x ->
-      of_gen (add h x) g
+  let to_seq h k = iter k h
 
-let to_gen h =
-  let stack = Stack.create () in
-  Stack.push h.tree stack;
-  let rec next () =
-    if Stack.is_empty stack
-    then None
-    else match Stack.pop stack with
-      | Empty -> next()
-      | Node (_, x, a, b) ->
-          Stack.push a stack;
-          Stack.push b stack;
-          Some x
-  in next
+  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 rec next stack () = match stack with
+      | [] -> `Nil
+      | E :: stack' -> next stack' ()
+      | N (_, x, a, b) :: stack' ->
+          `Cons (x, next (a :: b :: stack'))
+    in
+    next [h]
+
+  let rec of_gen h g = match g () with
+    | None -> h
+    | Some x ->
+        of_gen (add h x) g
+
+  let to_gen h =
+    let stack = Stack.create () in
+    Stack.push h stack;
+    let rec next () =
+      if Stack.is_empty stack
+      then None
+      else match Stack.pop stack with
+        | E -> next()
+        | 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
diff --git a/core/CCLeftistheap.mli b/core/CCLeftistheap.mli
index 9836ce9a..30e5b939 100644
--- a/core/CCLeftistheap.mli
+++ b/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}
-Polymorphic implementation, following Okasaki *)
+(** {1 Leftist Heaps} 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
-  (** Heap containing values of type 'a *)
+module type PARTIAL_ORD = sig
+  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
-  (** Empty heap. The function is used to check whether the first element is
-      smaller than the second. *)
+module type S = sig
+  type elt
+  type t
 
-val empty : 'a t
-  (** Empty heap using [Pervasives.compare] *)
+  val empty : t
+  (** Empty heap *)
 
-val is_empty : _ t -> bool
+  val is_empty : t -> bool
   (** Is the heap empty? *)
 
-val merge : 'a t -> 'a t -> 'a t
-  (** Merge two heaps (assume they have the same comparison function) *)
+  exception Empty
 
-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
-  (** Find minimal element, or fails
-      @raise Not_found if the heap is empty *)
+  val find_min : t -> elt option
+  (** Find minimal element *)
 
-val extract_min : 'a t -> 'a t * 'a
-  (** Extract and returns the minimal element, or
-      raise Not_found if the heap is empty *)
+  val find_min_exn : t -> elt
+  (** Same as {!find_min} but can fail
+      @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
-val to_seq : 'a t -> 'a sequence
+  (** {2 Conversions} *)
 
-val of_klist : 'a t -> 'a klist -> 'a t
-val to_klist : 'a t -> 'a klist
+  val to_list : t -> elt list
+  val of_list : elt list -> t
 
-val of_gen : 'a t -> 'a gen -> 'a t
-val to_gen : 'a t -> 'a gen
+  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) : S with type elt = E.t
diff --git a/tests/test_leftistheap.ml b/tests/test_leftistheap.ml
index 2204ca8c..1175f22c 100644
--- a/tests/test_leftistheap.ml
+++ b/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, x = Leftistheap.extract_min h in
+  let h = H.of_list [5;3;4;1;42;0] 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
-  OUnit.assert_equal n (Leftistheap.size h);
+  let h = H.of_seq empty (Sequence.of_list l) in
+  OUnit.assert_equal n (H.size h);
   let l' = extract_list h in
   OUnit.assert_bool "sorted" (is_sorted l');
   ()