Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 368 lines (310 sloc) 9.888 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Damien Lefortier
20 @author Corentin Gallet
21 **)
22
23 module type Ordered = sig
24 type t
25 val compare : t -> t -> int
26 end
27
28 (**
29
30 This file contains multiple implementations of (min) heaps.
31
32 [From Wikipedia, the free encyclopedia]
33
34 A heap is a tree data structure with ordered nodes where the min
35 (or max) value is the root of the tree and all children are less
36 than (or greater than) their parent nodes.
37
38 All the different implementations respect the following signature.
39
40 - Binary Heaps:
41
42 Imperative implementation, more efficient but not persistent.
43 Do not support merging.
44
45 - Binomial Heaps:
46
47 Functional implementation.
48 Support merging.
49
50 - Soft Heaps.
51
52 Functional implementation.
53 Support merging.
54
55 In comparison to previous structures, a better *amortized*
56 complexity can be obtained by allowing some elements of the heap to
57 be *corrupted*, i.e. to have their value increased after their
58 insertion. But more the number of extraction is important, more
59 the soft heaps are efficient, thus it isn't interesting at all to
60 use them just to do insertions.
61
62 **)
63
64 module type Sig = sig
65 type elt
66 type t
67 val empty : unit -> t
68 val is_empty : t -> bool
69 (** If the optional argument minimum is true, then the minimum is
70 not updated which is faster in some cases, this feature should
71 be used when many insertions are done in a row *)
72 val insert : t -> ?minimum:bool -> elt -> t
73 (** This function removes the minimum of the heap *)
74 val remove : t -> t
75 val minimum : t -> elt option
76 val merge : t -> t -> t
77 val iter : (elt -> unit) -> t -> unit
78 val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
79 val size : t -> int
80 end
81
82 module Binary(X : Ordered) = struct
83 type elt = X.t
84
85 type t = { mutable length : int; mutable data : X.t array }
86
87 let empty() = { length = 0 ; data = [||] }
88
89 let is_empty h =
90 h.length = 0
91
92 let insert h x =
93 let resize h x =
94 let n = Array.length h.data in
95 let data = Array.create (2 * n + 1) x in
96 Array.blit h.data 0 data 0 n ; h.data <- data ; h
97 in
98 let h = if h.length = Array.length h.data then resize h x else h in
99 let rec aux i =
100 let j = (i - 1) / 2
101 in if i > 0 && X.compare h.data.(j) x > 0 then begin
102 h.data.(i) <- h.data.(j) ;
103 aux j
104 end else begin
105 h.data.(i) <- x end
106 in
107 aux h.length ; h.length <- h.length + 1 ; h
108
109 let remove h =
110 let n = h.length - 1 in
111 let rec aux i x =
112 let j = 2 * i + 1 in
113 let k = j + 1 in
114 if j < n && (X.compare h.data.(j) x < 0 || X.compare h.data.(k) x < 0) then begin
115 let j = if k < n && X.compare h.data.(j) h.data.(k) > 0 then k else j
116 in
117 h.data.(i) <- h.data.(j) ;
118 aux j x
119 end else
120 h.data.(i) <- x
121 in match h.length with
122 | 0 -> h
123 | _ -> aux 0 h.data.(n) ; h.length <- n ; h
124
125 let minimum h = if h.length = 0 then None else Some h.data.(0)
126
127 let merge _ _ = assert false
128
129 let iter f h =
130 if (h.length == 0) then
131 ()
132 else
133 let rec aux k =
134 f h.data.(k);
135 if (k < h.length - 1) then
136 aux (k + 1);
137 in aux 0
138
139 let fold f h x0 =
140 if (h.length == 0) then
141 x0
142 else
143 let rec aux k l =
144 match l with
145 | 0 -> f h.data.(0) k
146 | _ -> aux (f h.data.(l) k) (l - 1)
147 in aux x0 (h.length - 1)
148
149 let size h = h.length
150
151 let to_string print_elt h =
152 let data = Array.to_list h.data in
153 let data = Base.String.concat_map "; " print_elt data in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
154 Printf.sprintf "heap{ len = %d; data = [%s]}" h.length data
fccc685 Initial open-source release
MLstate authored
155 end
156
157 module type Epsilon = sig
158 val epsilon : float
159 end
160
161 (** This is based on the following paper.
162
163 \@InProceedings\{
164 author = \{Kaplan,, Haim and Zwick,, Uri\},
165 title = \{A simpler implementation and analysis of Chazelle's soft heaps\},
166 booktitle = \{SODA '09: Proceedings of the Nineteenth Annual ACM -SIAM
167 Symposium on Discrete Algorithms\},
168 year = \{2009\},
169 pages = \{477--485\},
170 location = \{New York, New York\},
171 publisher = \{Society for Industrial and Applied Mathematics\},
172 address = \{Philadelphia, PA, USA\},
173 \}
174
175 **)
176
177 module Soft(X : Ordered)(E : Epsilon) = struct
178 type elt = X.t
179
180 (* A tree is as follows: (left,ckey,list,size,right) *)
181 type tree =
182 | Empty
183 | Node of tree * X.t * X.t list * int * tree
184
185 (* A node is as follows: [(root, smin, rank)], rank *)
186 type t = (tree * tree ref * int) list * int
187
188 let rate =
189 let log2 x = log10 x /. log10 2.0
190 in int_of_float (log2 (E.epsilon)) + 5
191
192 let empty() = [],0
193
194 let is_empty p = match fst p with
195 | [] -> true
196 | _ -> false
197
198 let leaf = function
199 | Node (Empty,_,_,_,Empty) -> true
200 | _ -> false
201 let ckey = function
202 | Empty -> assert false
203 | Node (_,ckey,_,_,_) -> ckey
204
205 let rec sift x =
206 match x with
207 | Empty -> assert false
208 | Node (Empty,_,_,_,Empty) -> x
209 | Node (_,_,c,s,_) when List.length c >= s -> x
210 | Node (l,ckey_,c,s,r) ->
211 let aux = function
212 | Empty
213 | Node (Empty,_,_,_,_) -> assert false
214 | Node (Node (l2,ckey_,c2,s2,r2) as l1,_,c1,s1,r1) ->
215 let l1 = match leaf l1 with
216 | true -> Empty
217 | _ -> sift (Node (l2,ckey_,[],s2,r2))
218 in Node (l1,ckey_,c1 @ c2,s1,r1)
219 and x = match l,r with
220 | Empty,_ -> Node (r,ckey_,c,s,l)
221 | l,r when r <> Empty && ckey l > ckey r -> Node (r,ckey_,c,s,l)
222 | _ -> x
223 in sift (aux x)
224
225 let rank = function
226 | (_,_,rank) -> rank
227 let smin = function
228 | (_,smin,_) -> smin
229 let root = function
230 | (root,_,_) -> root
231
232 let combine x y = match root x with
233 | Empty -> assert false
234 | Node (_,ckey,_,size,_) ->
235 let size = if rank x + 1 <= rate then 1 else (3 * size + 1) / 2
236 in sift (Node (root x,ckey,[],size,root y)), smin x, rank x + 1
237
238 let repeated_combine (lq,rq) k =
239 let rec aux = function
240 | [] -> assert false
241 | x :: [] -> [x], rank x
242 | x :: y :: lq when rank x = rank y ->
243 (match lq with
244 | z :: lq when rank z = rank x ->
245 let lq,rq = aux (combine y z :: lq)
246 in x :: lq, rq
247 | _ -> aux (combine x y :: lq))
248 | x :: lq when rank x > k -> x :: lq, rq
249 | x :: y :: lq ->
250 let lq,rq = aux (y :: lq)
251 in x :: lq, rq
252 in aux lq
253
254 let update_smin q f =
255 let rec aux = function
256 | [] -> []
257 | x :: lq ->
258 let update (root,_,rank) = function
259 | [] -> [(root,ref root,rank)]
260 | y :: lq -> (
261 if ckey root <= ckey (!(smin y)) then (root,ref root,rank)
262 else (root,ref !(smin y),rank)
263 ) :: y :: lq
264 in match f x with
265 | `continue x -> update x (aux lq)
266 | `break x -> update x lq
267 | `delete _x -> lq
268 in aux (fst q), snd q
269
270 let merge_ update p q =
271 let merge_into (lp,rp) (lq,rq) =
272 List.merge (fun x y -> compare (rank x) (rank y)) lp lq, max rp rq
273 and p,q = match p,q with
274 | p,q when snd p > snd q -> q,p
275 | _ -> p,q in
276 let q = repeated_combine (merge_into p q) (snd p)
277 in match update with
278 | true -> update_smin q (fun x -> `continue x)
279 | false -> q
280
281 let merge = merge_ true
282
283 let insert p ?(minimum=true) e =
284 let node = Node (Empty,e,[e],1,Empty)
285 in merge_ minimum ([node,ref node,0],0) p
286
287 let remove p = match fst p with
288 | [] -> p
289 | x :: _lq ->
290 match !(smin x) with
291 | Empty -> assert false
292 | Node (_,_,[],_,_) -> assert false
293 | Node (l,ckey,_ :: c,s,r) ->
294 let n = Node (l,ckey,c,s,r) in
295 let aux (_root,size,rank) =
296 if 2 * List.length c <= s then
297 match leaf n with
298 | false -> `break (sift n,size,rank)
299 | true ->
300 if List.length c = 0 then `delete n
301 else `break (n,size,rank)
302 else `break (n,size,rank) in
303 let f = (fun y ->
304 if root y == !(smin x) then (aux y) else `continue y)
305 in update_smin p f
306
307 let minimum p = match fst p with
308 | [] -> None
309 | x :: _lq ->
310 match !(smin x) with
311 | Empty -> assert false
312 | Node (_,_,[],_,_) -> assert false
313 | Node (_,_,e :: _,_,_) -> Some e
314
315 (* Useful for debug *)
316 let display string_of_elt (lp,rp) =
317 let string_of_list = function
318 | [] -> ""
319 | x :: xs -> List.fold_left (
320 fun acc x -> acc ^ "," ^ string_of_elt x
321 ) (string_of_elt x) xs
322 in
323 let rec dfs indent = function
324 | Empty -> ()
325 | Node (l,ckey,c,s,r) ->
326 Printf.printf "%s ckey = %s, list = [%s](%d), size = %d\n"
327 indent (string_of_elt ckey) (string_of_list c) (List.length c) s ;
328 dfs (indent ^ " ") l ;
329 dfs (indent ^ " ") r
330 in
331 Printf.printf "Heap of rank is %d with rate %d:\n" rp rate;
332 List.iter (
333 fun x ->
334 Printf.printf ">> Tree of rank is %d:\n" (rank x) ;
335 dfs " " (root x)
336 ) lp
337
338 let rec iter f h =
339 match h with
340 | [],_ -> ()
341 | (a, _, _)::t, _ ->
342 let rec aux ff tree =
343 match tree with
344 | Empty -> ()
345 | Node (l,_,c,_,r) ->
346 aux ff l; List.iter ff c; aux ff r
347 in aux f a; iter f (t, 0);;
348
349 let rec fold f h h0 =
350 match h with
351 | [], _ -> h0
352 | (a,_,_)::t, _ ->
353 let rec aux ff tree accu =
354 match tree with
355 | Empty -> accu
356 | Node (l,_,c,_,r) ->
357 match c with
358 | [] -> accu
359 | h::_t -> aux ff r (aux ff l (ff h accu))
360 in fold f (t, 0) (aux f a h0)
361 end
362
363 module ZeroCorruption = struct
364 let epsilon = max_float
365 end
366
367 module Binomial (X : Ordered) = Soft(X)(ZeroCorruption)
Something went wrong with that request. Please try again.