anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* Jean-Christophe Filliâtre *)
6(* *)
7(* Copyright 2023 CNRS *)
8(* *)
9(* All rights reserved. This file is distributed under the terms of *)
10(* the GNU Lesser General Public License version 2.1, with the *)
11(* special exception on linking described in the file LICENSE. *)
12(* *)
13(**************************************************************************)
14
15(* Priority queues over ordered elements.
16
17 We choose to have polymorphic elements here, so that we can later
18 derive both polymorphic and monomorphic priority queues from it.
19*)
20
21module type OrderedPolyType = sig
22 type 'a t
23 val compare : 'a t -> 'b t -> int
24end
25
26module MakeMinPoly(E: OrderedPolyType) =
27 struct
28
29 type 'a elt = 'a E.t
30
31 (* Our priority queues are implemented using the standard "min heap"
32 data structure, a dynamic array representing a binary tree. *)
33 type 'a t = 'a E.t Dynarray.t
34
35 let create =
36 Dynarray.create
37
38 let length =
39 Dynarray.length
40
41 let is_empty =
42 Dynarray.is_empty
43
44 let clear =
45 Dynarray.clear
46
47 (* The node at index [i] has children nodes at indices [2 * i + 1]
48 and [2 * i + 2] -- if they are valid indices in the dynarray. *)
49 let left_child i = 2 * i + 1
50 let right_child i = 2 * i + 2
51 let parent_node i = (i - 1) / 2
52
53 (* We say that a heap respects the "heap ordering" if the value of
54 each node is no greater than the value of its children. The
55 algorithm manipulates arrays that respect the heap ordering,
56 except for one node whose value may be too small or too large.
57
58 The auxiliary functions [sift_up] and [sift_down] take
59 such a misplaced value, and move it "up" (respectively: "down")
60 until the heap ordering is restored.
61
62 Functions [sift_up] and [sift_down] do not perform swaps, but
63 rather expect the value to be assigned in the heap as an
64 additional parameter [x], resulting in twice less assignments. *)
65
66 (* store [x] at index [i], moving it up if necessary *)
67 let rec sift_up h i x =
68 if i = 0 then Dynarray.set h 0 x else
69 let p = parent_node i in
70 let y = Dynarray.get h p in
71 if E.compare x y < 0 then (
72 Dynarray.set h i y;
73 sift_up h p x
74 ) else
75 Dynarray.set h i x
76
77 let add h x =
78 let i = Dynarray.length h in
79 Dynarray.add_last h x;
80 if i > 0 then sift_up h i x
81
82 let add_iter h iter x =
83 iter (add h) x
84
85 let min_elt h =
86 if Dynarray.is_empty h then None else Some (Dynarray.get h 0)
87
88 let get_min_elt h =
89 if Dynarray.is_empty h then invalid_arg "empty priority queue";
90 Dynarray.get h 0
91
92 let lt h i j =
93 E.compare (Dynarray.get h i) (Dynarray.get h j) < 0
94
95 (* store [x] at index [i], moving it down if necessary *)
96 let rec sift_down h ~len i x =
97 let left = left_child i in
98 if left >= len then Dynarray.set h i x (* no child, stop *) else
99 let smallest =
100 let right = right_child i in
101 if right >= len then left (* no right child *) else
102 if lt h left right then left else right
103 in
104 let y = Dynarray.get h smallest in
105 if E.compare y x < 0 then (
106 Dynarray.set h i y;
107 sift_down h ~len smallest x
108 ) else
109 Dynarray.set h i x
110
111 let pop_min h =
112 let n = Dynarray.length h in
113 if n = 0 then None else
114 let x = Dynarray.pop_last h in
115 if n = 1 then Some x else (
116 let r = Dynarray.get h 0 in
117 sift_down h ~len:(n - 1) 0 x;
118 Some r
119 )
120
121 let remove_min h =
122 let n = Dynarray.length h in
123 if n > 0 then (
124 let x = Dynarray.pop_last h in
125 if n > 1 then sift_down h ~len:(n - 1) 0 x
126 )
127
128 let copy =
129 Dynarray.copy
130
131 (* array to heap in linear time (Floyd, 1964)
132
133 many elements travel a short distance, few travel longer distances
134 and we can show that it totals to O(N) *)
135 let heapify h =
136 let n = Dynarray.length h in
137 for i = n/2 - 1 downto 0 do
138 sift_down h ~len:n i (Dynarray.get h i)
139 done;
140 h
141
142 let of_array a =
143 Dynarray.of_array a |> heapify
144
145 let of_list l =
146 Dynarray.of_list l |> heapify
147
148 let of_iter iter x =
149 let a = Dynarray.create () in
150 iter (Dynarray.add_last a) x;
151 heapify a
152
153 let iter_unordered =
154 Dynarray.iter
155
156 let fold_unordered =
157 Dynarray.fold_left
158
159 end
160
161module type MinPoly =
162 sig
163 type 'a t
164 type 'a elt
165 val create: unit ->'a t
166 val length: 'a t -> int
167 val is_empty: 'a t -> bool
168 val add: 'a t -> 'a elt -> unit
169 val add_iter: 'a t -> (('a elt -> unit) -> 'x -> unit) -> 'x -> unit
170 val min_elt: 'a t -> 'a elt option
171 val get_min_elt: 'a t -> 'a elt
172 val pop_min: 'a t -> 'a elt option
173 val remove_min: 'a t -> unit
174 val clear: 'a t -> unit
175 val copy: 'a t -> 'a t
176 val of_array: 'a elt array -> 'a t
177 val of_list: 'a elt list -> 'a t
178 val of_iter: (('a elt -> unit) -> 'x -> unit) -> 'x -> 'a t
179 val iter_unordered: ('a elt -> unit) -> 'a t -> unit
180 val fold_unordered: ('acc -> 'a elt -> 'acc) -> 'acc -> 'a t -> 'acc
181 end
182
183module type MaxPoly =
184 sig
185 type 'a t
186 type 'a elt
187 val create: unit -> 'a t
188 val length: 'a t -> int
189 val is_empty: 'a t -> bool
190 val add: 'a t -> 'a elt -> unit
191 val add_iter: 'a t -> (('a elt -> unit) -> 'x -> unit) -> 'x -> unit
192 val max_elt: 'a t -> 'a elt option
193 val get_max_elt: 'a t -> 'a elt
194 val pop_max: 'a t -> 'a elt option
195 val remove_max: 'a t -> unit
196 val clear: 'a t -> unit
197 val copy: 'a t -> 'a t
198 val of_array: 'a elt array -> 'a t
199 val of_list: 'a elt list -> 'a t
200 val of_iter: (('a elt -> unit) -> 'x -> unit) -> 'x -> 'a t
201 val iter_unordered: ('a elt -> unit) -> 'a t -> unit
202 val fold_unordered: ('acc -> 'a elt -> 'acc) -> 'acc -> 'a t -> 'acc
203end
204
205module MakeMaxPoly(E: OrderedPolyType)
206 : MaxPoly with type 'a elt = 'a E.t =
207 struct
208 include MakeMinPoly(struct
209 type 'a t = 'a E.t
210 let compare x y = E.compare y x
211 end)
212 (* renaming a few functions... *)
213 let max_elt = min_elt
214 let get_max_elt = get_min_elt
215 let pop_max = pop_min
216 let remove_max = remove_min
217 end
218
219(* Monomorphic priority queues *)
220
221module type OrderedType =
222 sig
223 type t
224 val compare: t -> t -> int
225 end
226
227module type Min =
228 sig
229 type t
230 type elt
231 val create: unit ->t
232 val length: t -> int
233 val is_empty: t -> bool
234 val add: t -> elt -> unit
235 val add_iter: t -> ((elt -> unit) -> 'x -> unit) -> 'x -> unit
236 val min_elt: t -> elt option
237 val get_min_elt: t -> elt
238 val pop_min: t -> elt option
239 val remove_min: t -> unit
240 val clear: t -> unit
241 val copy: t -> t
242 val of_array: elt array -> t
243 val of_list: elt list -> t
244 val of_iter: ((elt -> unit) -> 'x -> unit) -> 'x -> t
245 val iter_unordered: (elt -> unit) -> t -> unit
246 val fold_unordered: ('acc -> elt -> 'acc) -> 'acc -> t -> 'acc
247 end
248
249module MakeMin(E: OrderedType) =
250 struct
251 include MakeMinPoly(struct type 'a t = E.t
252 let compare = E.compare end)
253 type t = E.t Dynarray.t
254 end
255
256module type Max =
257 sig
258 type t
259 type elt
260 val create: unit ->t
261 val length: t -> int
262 val is_empty: t -> bool
263 val add: t -> elt -> unit
264 val add_iter: t -> ((elt -> unit) -> 'x -> unit) -> 'x -> unit
265 val max_elt: t -> elt option
266 val get_max_elt: t -> elt
267 val pop_max: t -> elt option
268 val remove_max: t -> unit
269 val clear: t -> unit
270 val copy: t -> t
271 val of_array: elt array -> t
272 val of_list: elt list -> t
273 val of_iter: ((elt -> unit) -> 'x -> unit) -> 'x -> t
274 val iter_unordered: (elt -> unit) -> t -> unit
275 val fold_unordered: ('acc -> elt -> 'acc) -> 'acc -> t -> 'acc
276 end
277
278module MakeMax(E: OrderedType) =
279 struct
280 include MakeMinPoly(struct type 'a t = E.t
281 let compare x y = E.compare y x end)
282 type t = E.t Dynarray.t
283 let max_elt = min_elt
284 let get_max_elt = get_min_elt
285 let pop_max = pop_min
286 let remove_max = remove_min
287 end