From b6212bea7c47844d94559a5a13f005d266c29455 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 23 Apr 2013 20:27:33 +0200 Subject: [PATCH] leftistheap --- leftistheap.ml | 108 ++++++++++++++++++++++++++++++++++++++ leftistheap.mli | 60 +++++++++++++++++++++ tests/run_tests.ml | 1 + tests/test_leftistheap.ml | 55 +++++++++++++++++++ 4 files changed, 224 insertions(+) create mode 100644 leftistheap.ml create mode 100644 leftistheap.mli create mode 100644 tests/test_leftistheap.ml diff --git a/leftistheap.ml b/leftistheap.ml new file mode 100644 index 00000000..0c1c5675 --- /dev/null +++ b/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) diff --git a/leftistheap.mli b/leftistheap.mli new file mode 100644 index 00000000..b01f4741 --- /dev/null +++ b/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 diff --git a/tests/run_tests.ml b/tests/run_tests.ml index 44377efd..e9ce86a9 100644 --- a/tests/run_tests.ml +++ b/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; diff --git a/tests/test_leftistheap.ml b/tests/test_leftistheap.ml new file mode 100644 index 00000000..e5f124c4 --- /dev/null +++ b/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! *) + ]