This commit is contained in:
Simon Cruanes 2024-10-02 12:31:53 -04:00
parent afb93cfc43
commit 9bef25b6e2
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
3 changed files with 147 additions and 161 deletions

View file

@ -10,10 +10,11 @@ type 'a ktree = unit -> [ `Nil | `Node of 'a * 'a ktree list ]
let[@inline] _iter_map f xs k = xs (fun x -> k (f x))
let rec _gen_iter k g =
begin match g () with
match g () with
| None -> ()
| Some x -> k x; _gen_iter k g
end
| Some x ->
k x;
_gen_iter k g
module type PARTIAL_ORD = sig
type t
@ -356,12 +357,10 @@ module Make (E : PARTIAL_ORD) : S with type elt = E.t = struct
equal to it. *)
let _merge_heap_iter (hs : t iter) : t =
let rec cons_and_merge h0 hs weights =
begin match hs with
match hs with
| h1 :: hs' when weights land 1 = 0 ->
cons_and_merge (merge h0 h1) hs' (weights lsr 1)
| _ ->
h0 :: hs
end
cons_and_merge (merge h0 h1) hs' (weights lsr 1)
| _ -> h0 :: hs
in
(* the i-th heap in this list is a merger of 2^{w_i} input heaps, each
having gone through w_i merge operations, where the "weights" 2^{w_i} are
@ -371,19 +370,14 @@ module Make (E : PARTIAL_ORD) : S with type elt = E.t = struct
input heaps merged so far; adding a heap to the mergers works like binary
incrementation: *)
let count = ref 0 in
hs begin fun h ->
incr count ;
mergers := cons_and_merge h !mergers !count ;
end ;
hs (fun h ->
incr count;
mergers := cons_and_merge h !mergers !count);
List.fold_left merge E !mergers
(* To build a heap with n given values, instead of repeated insertions,
it is more efficient to do pairwise merging, running in time O(n). *)
let of_iter xs =
xs
|> _iter_map singleton
|> _merge_heap_iter
let of_iter xs = xs |> _iter_map singleton |> _merge_heap_iter
let of_list xs = of_iter (fun k -> List.iter k xs)
let of_seq xs = of_iter (fun k -> Seq.iter k xs)
let of_gen xs = of_iter (fun k -> _gen_iter k xs)
@ -401,15 +395,12 @@ module Make (E : PARTIAL_ORD) : S with type elt = E.t = struct
let of_iter_almost_sorted xs =
let sorted_chunk = ref [] in
let iter_sorted_heaps k =
xs begin fun x ->
begin match !sorted_chunk with
| (y :: _) as ys when not (E.leq y x) ->
k (_of_list_rev_sorted ys) ;
sorted_chunk := [x]
| ys ->
sorted_chunk := x :: ys
end ;
end ;
xs (fun x ->
match !sorted_chunk with
| y :: _ as ys when not (E.leq y x) ->
k (_of_list_rev_sorted ys);
sorted_chunk := [ x ]
| ys -> sorted_chunk := x :: ys);
k (_of_list_rev_sorted !sorted_chunk)
in
_merge_heap_iter iter_sorted_heaps
@ -420,7 +411,6 @@ module Make (E : PARTIAL_ORD) : S with type elt = E.t = struct
let add_iter h xs = merge h (of_iter xs)
let add_seq h xs = merge h (of_seq xs)
let add_gen h xs = merge h (of_gen xs)
let add_iter_almost_sorted h xs = merge h (of_iter_almost_sorted xs)
(** {2 Conversions to sequences} *)
@ -494,19 +484,19 @@ module Make (E : PARTIAL_ORD) : S with type elt = E.t = struct
let rec delete_one eq x0 = function
| N (_, x, l, r) as h when E.leq x x0 ->
if eq x0 x then
merge l r
else begin
let l' = delete_one eq x0 l in
if CCEqual.physical l' l then
let r' = delete_one eq x0 r in
if CCEqual.physical r' r then
h
else
_make_node x l r'
if eq x0 x then
merge l r
else (
let l' = delete_one eq x0 l in
if CCEqual.physical l' l then (
let r' = delete_one eq x0 r in
if CCEqual.physical r' r then
h
else
_make_node x l' r
end
_make_node x l r'
) else
_make_node x l' r
)
| h -> h
let delete_all eq x0 h =
@ -524,42 +514,40 @@ module Make (E : PARTIAL_ORD) : S with type elt = E.t = struct
much smaller than O(n) if k is asymptotically smaller than n.
*)
let rec iter_subheaps eq x0 h k =
begin match h with
match h with
| N (_, x, l, r) when E.leq x x0 ->
let keep_x = not (eq x0 x) in
let keep_l = iter_subheaps eq x0 l k in
let keep_r = iter_subheaps eq x0 r k in
if keep_x && keep_l && keep_r then
true
else begin
if keep_x then k (singleton x) ;
if keep_l then k l ;
if keep_r then k r ;
false
end
let keep_x = not (eq x0 x) in
let keep_l = iter_subheaps eq x0 l k in
let keep_r = iter_subheaps eq x0 r k in
if keep_x && keep_l && keep_r then
true
else (
if keep_x then k (singleton x);
if keep_l then k l;
if keep_r then k r;
false
)
| _ -> true
end
in
_merge_heap_iter (fun k -> if iter_subheaps eq x0 h k then k h)
let filter p h =
(* similar to [delete_all] *)
let rec iter_subheaps p k h =
begin match h with
match h with
| E -> true
| N (_, x, l, r) ->
let keep_x = p x in
let keep_l = iter_subheaps p k l in
let keep_r = iter_subheaps p k r in
if keep_x && keep_l && keep_r then
true
else begin
if keep_x then k (singleton x) ;
if keep_l then k l ;
if keep_r then k r ;
false
end
end
let keep_x = p x in
let keep_l = iter_subheaps p k l in
let keep_r = iter_subheaps p k r in
if keep_x && keep_l && keep_r then
true
else (
if keep_x then k (singleton x);
if keep_l then k l;
if keep_r then k r;
false
)
in
_merge_heap_iter (fun k -> if iter_subheaps p k h then k h)

View file

@ -1,4 +1,3 @@
(tests
(ocamlopt_flags :standard -inline 1000)
(names t_reg454)

View file

@ -8,233 +8,232 @@ include T
* generated by [QCheck.list].
* QCheck defines this generator under the name [nat] but does not expose it. *)
let medium_nat =
Q.make ~print:Q.Print.int ~shrink:Q.Shrink.int ~small:(fun _ -> 1)
Q.make ~print:Q.Print.int ~shrink:Q.Shrink.int
~small:(fun _ -> 1)
(fun st ->
let p = Random.State.float st 1. in
if p < 0.5 then Random.State.int st 10
else if p < 0.75 then Random.State.int st 100
else if p < 0.95 then Random.State.int st 1_000
else Random.State.int st 10_000
)
let p = Random.State.float st 1. in
if p < 0.5 then
Random.State.int st 10
else if p < 0.75 then
Random.State.int st 100
else if p < 0.95 then
Random.State.int st 1_000
else
Random.State.int st 10_000)
let list_delete_first (x0 : int) (xs : int list) : int list =
let rec aux acc xs =
begin match xs with
match xs with
| [] -> List.rev acc
| x :: xs' when x = x0 -> List.rev_append acc xs'
| x :: xs' -> aux (x :: acc) xs'
end
in
aux [] xs
module H = CCHeap.Make (struct
type t = int
let leq x y = x <= y
end)
;;
t ~name:"of_list, find_min_exn, take_exn" @@ fun () ->
let h = H.of_list [ 5; 4; 3; 4; 1; 42; 0 ] in
assert_equal ~printer:string_of_int 0 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 0 x;
assert_equal ~printer:string_of_int 1 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 1 x;
assert_equal ~printer:string_of_int 3 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 3 x;
assert_equal ~printer:string_of_int 4 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 4 x;
assert_equal ~printer:string_of_int 4 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 4 x;
assert_equal ~printer:string_of_int 5 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 5 x;
assert_equal ~printer:string_of_int 42 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 42 x;
assert_raises ((=) H.Empty) (fun () -> H.find_min_exn h);
assert_raises ((=) H.Empty) (fun () -> H.take_exn h);
true
let h = H.of_list [ 5; 4; 3; 4; 1; 42; 0 ] in
assert_equal ~printer:string_of_int 0 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 0 x;
assert_equal ~printer:string_of_int 1 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 1 x;
assert_equal ~printer:string_of_int 3 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 3 x;
assert_equal ~printer:string_of_int 4 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 4 x;
assert_equal ~printer:string_of_int 4 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 4 x;
assert_equal ~printer:string_of_int 5 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 5 x;
assert_equal ~printer:string_of_int 42 (H.find_min_exn h);
let h, x = H.take_exn h in
assert_equal ~printer:string_of_int 42 x;
assert_raises (( = ) H.Empty) (fun () -> H.find_min_exn h);
assert_raises (( = ) H.Empty) (fun () -> H.take_exn h);
true
;;
q ~name:"of_list, to_list"
~count:30
q ~name:"of_list, to_list" ~count:30
Q.(list medium_nat)
(fun l ->
(l |> H.of_list |> H.to_list |> List.sort CCInt.compare)
l |> H.of_list |> H.to_list |> List.sort CCInt.compare
= (l |> List.sort CCInt.compare))
;;
q ~name:"of_list, to_list_sorted"
~count:30
q ~name:"of_list, to_list_sorted" ~count:30
Q.(list medium_nat)
(fun l ->
(l |> H.of_list |> H.to_list_sorted)
= (l |> List.sort CCInt.compare))
(fun l -> l |> H.of_list |> H.to_list_sorted = (l |> List.sort CCInt.compare))
;;
(* The remaining tests assume the correctness of
[of_list], [to_list], [to_list_sorted]. *)
q ~name:"size"
~count:30
q ~name:"size" ~count:30
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.size)
= (l |> List.length))
(fun l -> l |> H.of_list |> H.size = (l |> List.length))
;;
q ~name:"insert"
Q.(pair medium_nat (list medium_nat))
(fun (x, l) ->
(l |> H.of_list |> H.insert x |> H.to_list_sorted)
= ((x::l) |> List.sort CCInt.compare))
l |> H.of_list |> H.insert x |> H.to_list_sorted
= (x :: l |> List.sort CCInt.compare))
;;
q ~name:"merge"
Q.(pair (list medium_nat) (list medium_nat))
(fun (l1, l2) ->
(H.merge (H.of_list l1) (H.of_list l2) |> H.to_list_sorted)
= ((l1@l2) |> List.sort CCInt.compare))
H.merge (H.of_list l1) (H.of_list l2)
|> H.to_list_sorted
= (l1 @ l2 |> List.sort CCInt.compare))
;;
q ~name:"add_list"
Q.(pair (list medium_nat) (list medium_nat))
(fun (l1, l2) ->
(H.add_list (H.of_list l1) l2 |> H.to_list_sorted)
= ((l1@l2) |> List.sort CCInt.compare))
H.add_list (H.of_list l1) l2
|> H.to_list_sorted
= (l1 @ l2 |> List.sort CCInt.compare))
;;
q ~name:"delete_one"
Q.(pair medium_nat (list medium_nat))
(fun (x, l) ->
(l |> H.of_list |> H.delete_one (=) x |> H.to_list_sorted)
l |> H.of_list |> H.delete_one ( = ) x |> H.to_list_sorted
= (l |> list_delete_first x |> List.sort CCInt.compare))
;;
q ~name:"delete_all"
Q.(pair medium_nat (list medium_nat))
(fun (x, l) ->
(l |> H.of_list |> H.delete_all (=) x |> H.to_list_sorted)
= (l |> List.filter ((<>) x) |> List.sort CCInt.compare))
l |> H.of_list |> H.delete_all ( = ) x |> H.to_list_sorted
= (l |> List.filter (( <> ) x) |> List.sort CCInt.compare))
;;
q ~name:"filter"
Q.(list medium_nat)
(fun l ->
let p = (fun x -> x mod 2 = 0) in
let p x = x mod 2 = 0 in
let l' = l |> H.of_list |> H.filter p |> H.to_list in
List.for_all p l' && List.length l' = List.length (List.filter p l))
;;
t ~name:"physical equality" @@ fun () ->
let h = H.of_list [ 5; 4; 3; 4; 1; 42; 0 ] in
assert_bool "physical equality of merge with left empty"
(CCEqual.physical h (H.merge H.empty h)) ;
assert_bool "physical equality of merge with right empty"
(CCEqual.physical h (H.merge h H.empty)) ;
assert_bool "physical equality of delete_one with element lesser than min"
(CCEqual.physical h (H.delete_one (=) (-999) h)) ;
assert_bool "physical equality of delete_one with element between min and max"
(CCEqual.physical h (H.delete_one (=) 2 h)) ;
assert_bool "physical equality of delete_one with element greater than max"
(CCEqual.physical h (H.delete_one (=) 999 h)) ;
assert_bool "physical equality of delete_all with element lesser than min"
(CCEqual.physical h (H.delete_all (=) (-999) h)) ;
assert_bool "physical equality of delete_all with element between min and max"
(CCEqual.physical h (H.delete_all (=) 2 h)) ;
assert_bool "physical equality of delete_all with element greater than max"
(CCEqual.physical h (H.delete_all (=) 999 h)) ;
assert_bool "physical equality of filter"
(CCEqual.physical h (H.filter (fun _ -> true) h)) ;
true
let h = H.of_list [ 5; 4; 3; 4; 1; 42; 0 ] in
assert_bool "physical equality of merge with left empty"
(CCEqual.physical h (H.merge H.empty h));
assert_bool "physical equality of merge with right empty"
(CCEqual.physical h (H.merge h H.empty));
assert_bool "physical equality of delete_one with element lesser than min"
(CCEqual.physical h (H.delete_one ( = ) (-999) h));
assert_bool "physical equality of delete_one with element between min and max"
(CCEqual.physical h (H.delete_one ( = ) 2 h));
assert_bool "physical equality of delete_one with element greater than max"
(CCEqual.physical h (H.delete_one ( = ) 999 h));
assert_bool "physical equality of delete_all with element lesser than min"
(CCEqual.physical h (H.delete_all ( = ) (-999) h));
assert_bool "physical equality of delete_all with element between min and max"
(CCEqual.physical h (H.delete_all ( = ) 2 h));
assert_bool "physical equality of delete_all with element greater than max"
(CCEqual.physical h (H.delete_all ( = ) 999 h));
assert_bool "physical equality of filter"
(CCEqual.physical h (H.filter (fun _ -> true) h));
true
;;
q ~name:"fold"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.fold (+) 0)
= (l |> List.fold_left (+) 0))
(fun l -> l |> H.of_list |> H.fold ( + ) 0 = (l |> List.fold_left ( + ) 0))
;;
q ~name:"of_iter"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> CCList.to_iter |> H.of_iter |> H.to_list_sorted)
l |> CCList.to_iter |> H.of_iter |> H.to_list_sorted
= (l |> List.sort CCInt.compare))
;;
q ~name:"of_seq"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> CCList.to_seq |> H.of_seq |> H.to_list_sorted)
l |> CCList.to_seq |> H.of_seq |> H.to_list_sorted
= (l |> List.sort CCInt.compare))
;;
q ~name:"of_gen"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> CCList.to_gen |> H.of_gen |> H.to_list_sorted)
l |> CCList.to_gen |> H.of_gen |> H.to_list_sorted
= (l |> List.sort CCInt.compare))
;;
q ~name:"to_iter"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.to_iter |> CCList.of_iter |> List.sort CCInt.compare)
l |> H.of_list |> H.to_iter |> CCList.of_iter |> List.sort CCInt.compare
= (l |> List.sort CCInt.compare))
;;
q ~name:"to_seq"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.to_seq |> CCList.of_seq |> List.sort CCInt.compare)
l |> H.of_list |> H.to_seq |> CCList.of_seq |> List.sort CCInt.compare
= (l |> List.sort CCInt.compare))
;;
q ~name:"to_gen"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.to_gen |> CCList.of_gen |> List.sort CCInt.compare)
l |> H.of_list |> H.to_gen |> CCList.of_gen |> List.sort CCInt.compare
= (l |> List.sort CCInt.compare))
;;
q ~name:"to_iter_sorted"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.to_iter_sorted |> Iter.to_list)
l |> H.of_list |> H.to_iter_sorted |> Iter.to_list
= (l |> List.sort CCInt.compare))
;;
q ~name:"to_seq_sorted"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.to_seq_sorted |> CCList.of_seq |> List.sort CCInt.compare)
l |> H.of_list |> H.to_seq_sorted |> CCList.of_seq
|> List.sort CCInt.compare
= (l |> List.sort CCInt.compare))
;;
q ~name:"to_string with default sep"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.to_string string_of_int)
= (l |> List.sort CCInt.compare |> List.map string_of_int |> String.concat ","))
l |> H.of_list |> H.to_string string_of_int
= (l |> List.sort CCInt.compare |> List.map string_of_int
|> String.concat ","))
;;
q ~name:"to_string with space as sep"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
(l |> H.of_list |> H.to_string ~sep:" " string_of_int)
= (l |> List.sort CCInt.compare |> List.map string_of_int |> String.concat " "))
l |> H.of_list
|> H.to_string ~sep:" " string_of_int
= (l |> List.sort CCInt.compare |> List.map string_of_int
|> String.concat " "))
;;
q ~name:"Make_from_compare"
Q.(list_of_size Gen.small_nat medium_nat)
(fun l ->
let module H' = Make_from_compare (CCInt) in
(l |> H'.of_list |> H'.to_list_sorted)
= (l |> List.sort CCInt.compare))
l |> H'.of_list |> H'.to_list_sorted = (l |> List.sort CCInt.compare))