leftistheap

leftistheap.ml

@@ -0,0 +1,108 @@
+(*
+Copyright (c) 2013, Simon Cruanes
+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 HOLDER 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.
+*)
+
+(** {1 Leftist Heaps *)
+
+(** Polymorphic implementation, following Okasaki *)
+
+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
+
+let empty ~leq =
+  { tree = Empty;
+    leq;
+  }
+
+let is_empty heap =
+  match heap.tree with
+  | Empty -> true
+  | _ -> false
+
+(** Rank of the tree *)
+let rank_tree t = match t with
+  | Empty -> 0
+  | Node (r, _, _, _) -> r
+
+(** 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)
+
+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)
+
+let merge h1 h2 =
+  let tree = merge_tree h1.leq h1.tree h2.tree in
+  { tree; leq=h1.leq; }
+
+let insert heap x =
+  let tree = merge_tree heap.leq (Node (1, x, Empty, Empty)) heap.tree in
+  { heap with tree; }
+
+let find_min heap =
+  match heap.tree with
+  | Empty -> raise Not_found
+  | Node (_, x, _, _) -> x
+
+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
+
+let iter heap f =
+  let rec iter t = match t with
+    | Empty -> ()
+    | Node (_, x, a, b) ->
+      f x;
+      iter a;
+      iter b;
+  in iter heap.tree
+
+let size heap =
+  let r = ref 0 in
+  iter heap (fun _ -> incr r);
+  !r
+
+let of_seq heap seq =
+  Sequence.fold insert heap seq
+
+let to_seq heap =
+  Sequence.from_iter (fun k -> iter heap k)

leftistheap.mli

@@ -0,0 +1,60 @@
+(*
+Copyright (c) 2013, Simon Cruanes
+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 HOLDER 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.
+*)
+
+(** {1 Leftist Heaps *)
+
+(** Polymorphic implementation, following Okasaki *)
+
+type 'a t
+  (** Heap containing values of type 'a *)
+
+val empty : leq:('a -> 'a -> bool) -> 'a t
+  (** Empty heap. The function is used to check whether
+      the first element is smaller than the second. *)
+
+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) *)
+
+val insert : 'a t -> 'a -> 'a t
+  (** Insert a value in the heap *)
+
+val find_min : 'a t -> 'a
+  (** Find minimal element, or raise Not_found *)
+
+val extract_min : 'a t -> 'a t * 'a
+  (** Extract and returns the minimal element, or raise Not_found *)
+
+val iter : 'a t -> ('a -> unit) -> unit
+  (** Iterate on elements *)
+
+val size : _ t -> int
+  (** Number of elements (linear) *)
+
+val of_seq : 'a t -> 'a Sequence.t -> 'a t
+
+val to_seq : 'a t -> 'a Sequence.t

tests/run_tests.ml

@@ -6,6 +6,7 @@ let suite =
   "all_tests" >:::
     [ Test_pHashtbl.suite;
       Test_PersistentHashtbl.suite;
+      Test_leftistheap.suite;
       Test_cc.suite;
       Test_puf.suite;
       Test_vector.suite;

tests/test_leftistheap.ml

@@ -0,0 +1,55 @@
+
+(* test leftistheap *)
+
+open OUnit
+
+let empty = Leftistheap.empty ~leq:(fun i j -> i <= j)
+
+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
+  OUnit.assert_equal ~printer:string_of_int 0 x;
+  let h, x = Leftistheap.extract_min h in
+  OUnit.assert_equal ~printer:string_of_int 1 x;
+  let h, x = Leftistheap.extract_min h in
+  OUnit.assert_equal ~printer:string_of_int 3 x;
+  let h, x = Leftistheap.extract_min h in
+  OUnit.assert_equal ~printer:string_of_int 4 x;
+  let h, x = Leftistheap.extract_min h in
+  OUnit.assert_equal ~printer:string_of_int 5 x;
+  let h, x = Leftistheap.extract_min h in
+  OUnit.assert_equal ~printer:string_of_int 42 x;
+  OUnit.assert_raises Not_found (fun () -> Leftistheap.extract_min h);
+  ()
+
+let rec is_sorted l = match l with
+  | [_]
+  | [] -> true
+  | x::((y::_) as l') -> x <= y && is_sorted l'
+
+let extract_list heap =
+  let rec recurse acc h =
+    if Leftistheap.is_empty h
+      then List.rev acc
+      else
+        let h', x = Leftistheap.extract_min h in
+        recurse (x::acc) h'
+  in
+  recurse [] heap
+
+(* heap sort on a random list *)
+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 l' = extract_list h in
+  OUnit.assert_bool "sorted" (is_sorted l');
+  ()
+
+let suite =
+  "test_leftistheap" >:::
+    [ "test1" >:: test1;
+      "test_sort" >:: test_sort;
+      "test_sort2" >:: test_sort;  (* random! *)
+    ]