Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Heap::Fibonacci; |
2 | ||
3 | use strict; | |
4 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
5 | ||
6 | require Exporter; | |
7 | require AutoLoader; | |
8 | ||
9 | @ISA = qw(Exporter AutoLoader); | |
10 | ||
11 | # No names exported. | |
12 | # No names available for export. | |
13 | @EXPORT = ( ); | |
14 | ||
15 | $VERSION = '0.70'; | |
16 | ||
17 | ||
18 | # Preloaded methods go here. | |
19 | ||
20 | # common names | |
21 | # h - heap head | |
22 | # el - linkable element, contains user-provided value | |
23 | # v - user-provided value | |
24 | ||
25 | ################################################# debugging control | |
26 | ||
27 | my $debug = 0; | |
28 | my $validate = 0; | |
29 | ||
30 | # enable/disable debugging output | |
31 | sub debug { | |
32 | @_ ? ($debug = shift) : $debug; | |
33 | } | |
34 | ||
35 | # enable/disable validation checks on values | |
36 | sub validate { | |
37 | @_ ? ($validate = shift) : $validate; | |
38 | } | |
39 | ||
40 | my $width = 3; | |
41 | my $bar = ' | '; | |
42 | my $corner = ' +-'; | |
43 | my $vfmt = "%3d"; | |
44 | ||
45 | sub set_width { | |
46 | $width = shift; | |
47 | $width = 2 if $width < 2; | |
48 | ||
49 | $vfmt = "%${width}d"; | |
50 | $bar = $corner = ' ' x $width; | |
51 | substr($bar,-2,1) = '|'; | |
52 | substr($corner,-2,2) = '+-'; | |
53 | } | |
54 | ||
55 | sub hdump; | |
56 | ||
57 | sub hdump { | |
58 | my $el = shift; | |
59 | my $l1 = shift; | |
60 | my $b = shift; | |
61 | ||
62 | my $ch; | |
63 | my $ch1; | |
64 | ||
65 | unless( $el ) { | |
66 | print $l1, "\n"; | |
67 | return; | |
68 | } | |
69 | ||
70 | hdump $ch1 = $el->{child}, | |
71 | $l1 . sprintf( $vfmt, $el->{val}->val), | |
72 | $b . $bar; | |
73 | ||
74 | if( $ch1 ) { | |
75 | for( $ch = $ch1->{right}; $ch != $ch1; $ch = $ch->{right} ) { | |
76 | hdump $ch, $b . $corner, $b . $bar; | |
77 | } | |
78 | } | |
79 | } | |
80 | ||
81 | sub heapdump { | |
82 | my $h; | |
83 | ||
84 | while( $h = shift ) { | |
85 | my $top = $$h or last; | |
86 | my $el = $top; | |
87 | ||
88 | do { | |
89 | hdump $el, sprintf( "%02d: ", $el->{degree}), ' '; | |
90 | $el = $el->{right}; | |
91 | } until $el == $top; | |
92 | print "\n"; | |
93 | } | |
94 | } | |
95 | ||
96 | sub bhcheck; | |
97 | ||
98 | sub bhcheck { | |
99 | my $el = shift; | |
100 | my $p = shift; | |
101 | ||
102 | my $cur = $el; | |
103 | my $prev; | |
104 | my $ch; | |
105 | do { | |
106 | $prev = $cur; | |
107 | $cur = $cur->{right}; | |
108 | die "bad back link" unless $cur->{left} == $prev; | |
109 | die "bad parent link" | |
110 | unless (defined $p && defined $cur->{p} && $cur->{p} == $p) | |
111 | || (!defined $p && !defined $cur->{p}); | |
112 | die "bad degree( $cur->{degree} > $p->{degree} )" | |
113 | if $p && $p->{degree} <= $cur->{degree}; | |
114 | die "not heap ordered" | |
115 | if $p && $p->{val}->cmp($cur->{val}) > 0; | |
116 | $ch = $cur->{child} and bhcheck $ch, $cur; | |
117 | } until $cur == $el; | |
118 | } | |
119 | ||
120 | ||
121 | sub heapcheck { | |
122 | my $h; | |
123 | my $el; | |
124 | while( $h = shift ) { | |
125 | heapdump $h if $validate >= 2; | |
126 | $el = $$h and bhcheck $el, undef; | |
127 | } | |
128 | } | |
129 | ||
130 | ||
131 | ################################################# forward declarations | |
132 | ||
133 | sub ascending_cut; | |
134 | sub elem; | |
135 | sub elem_DESTROY; | |
136 | sub link_to_left_of; | |
137 | ||
138 | ################################################# heap methods | |
139 | ||
140 | # Cormen et al. use two values for the heap, a pointer to an element in the | |
141 | # list at the top, and a count of the number of elements. The count is only | |
142 | # used to determine the size of array required to hold log(count) pointers, | |
143 | # but perl can set array sizes as needed and doesn't need to know their size | |
144 | # when they are created, so we're not maintaining that field. | |
145 | sub new { | |
146 | my $self = shift; | |
147 | my $class = ref($self) || $self; | |
148 | my $h = undef; | |
149 | bless \$h, $class; | |
150 | } | |
151 | ||
152 | sub DESTROY { | |
153 | my $h = shift; | |
154 | ||
155 | elem_DESTROY $$h; | |
156 | } | |
157 | ||
158 | sub add { | |
159 | my $h = shift; | |
160 | my $v = shift; | |
161 | $validate && do { | |
162 | die "Method 'heap' required for element on heap" | |
163 | unless $v->can('heap'); | |
164 | die "Method 'cmp' required for element on heap" | |
165 | unless $v->can('cmp'); | |
166 | }; | |
167 | my $el = elem $v; | |
168 | my $top; | |
169 | if( !($top = $$h) ) { | |
170 | $$h = $el; | |
171 | } else { | |
172 | link_to_left_of $top->{left}, $el ; | |
173 | link_to_left_of $el,$top; | |
174 | $$h = $el if $v->cmp($top->{val}) < 0; | |
175 | } | |
176 | } | |
177 | ||
178 | sub top { | |
179 | my $h = shift; | |
180 | $$h && $$h->{val}; | |
181 | } | |
182 | ||
183 | *minimum = \⊤ | |
184 | ||
185 | sub extract_top { | |
186 | my $h = shift; | |
187 | my $el = $$h or return undef; | |
188 | my $ltop = $el->{left}; | |
189 | my $cur; | |
190 | my $next; | |
191 | ||
192 | # $el is the heap with the lowest value on it | |
193 | # move all of $el's children (if any) to the top list (between | |
194 | # $ltop and $el) | |
195 | if( $cur = $el->{child} ) { | |
196 | # remember the beginning of the list of children | |
197 | my $first = $cur; | |
198 | do { | |
199 | # the children are moving to the top, clear the p | |
200 | # pointer for all of them | |
201 | $cur->{p} = undef; | |
202 | } until ($cur = $cur->{right}) == $first; | |
203 | ||
204 | # remember the end of the list | |
205 | $cur = $cur->{left}; | |
206 | link_to_left_of $ltop, $first; | |
207 | link_to_left_of $cur, $el; | |
208 | } | |
209 | ||
210 | if( $el->{right} == $el ) { | |
211 | # $el had no siblings or children, the top only contains $el | |
212 | # and $el is being removed | |
213 | $$h = undef; | |
214 | } else { | |
215 | link_to_left_of $el->{left}, $$h = $el->{right}; | |
216 | # now all those loose ends have to be merged together as we | |
217 | # search for the | |
218 | # new smallest element | |
219 | $h->consolidate; | |
220 | } | |
221 | ||
222 | # extract the actual value and return that, $el is no longer used | |
223 | # but break all of its links so that it won't be pointed to... | |
224 | my $top = $el->{val}; | |
225 | $top->heap(undef); | |
226 | $el->{left} = $el->{right} = $el->{p} = $el->{child} = $el->{val} = | |
227 | undef; | |
228 | $top; | |
229 | } | |
230 | ||
231 | *extract_minimum = \&extract_top; | |
232 | ||
233 | sub absorb { | |
234 | my $h = shift; | |
235 | my $h2 = shift; | |
236 | ||
237 | my $el = $$h; | |
238 | unless( $el ) { | |
239 | $$h = $$h2; | |
240 | $$h2 = undef; | |
241 | return $h; | |
242 | } | |
243 | ||
244 | my $el2 = $$h2 or return $h; | |
245 | ||
246 | # add $el2 and its siblings to the head list for $h | |
247 | # at start, $ell -> $el -> ... -> $ell is on $h (where $ell is | |
248 | # $el->{left}) | |
249 | # $el2l -> $el2 -> ... -> $el2l are on $h2 | |
250 | # at end, $ell -> $el2l -> ... -> $el2 -> $el -> ... -> $ell are | |
251 | # all on $h | |
252 | my $el2l = $el2->{left}; | |
253 | link_to_left_of $el->{left}, $el2; | |
254 | link_to_left_of $el2l, $el; | |
255 | ||
256 | # change the top link if needed | |
257 | $$h = $el2 if $el->{val}->cmp( $el2->{val} ) > 0; | |
258 | ||
259 | # clean out $h2 | |
260 | $$h2 = undef; | |
261 | ||
262 | # return the heap | |
263 | $h; | |
264 | } | |
265 | ||
266 | # a key has been decreased, it may have to percolate up in its heap | |
267 | sub decrease_key { | |
268 | my $h = shift; | |
269 | my $top = $$h; | |
270 | my $v = shift; | |
271 | my $el = $v->heap or return undef; | |
272 | my $p; | |
273 | ||
274 | # first, link $h to $el if it is now the smallest (we will | |
275 | # soon link $el to $top to properly put it up to the top list, | |
276 | # if it isn't already there) | |
277 | $$h = $el if $top->{val}->cmp( $v ) > 0; | |
278 | ||
279 | if( $p = $el->{p} and $v->cmp($p->{val}) < 0 ) { | |
280 | # remove $el from its parent's list - it is now smaller | |
281 | ||
282 | ascending_cut $top, $p, $el; | |
283 | } | |
284 | ||
285 | $v; | |
286 | } | |
287 | ||
288 | ||
289 | # to delete an item, we bubble it to the top of its heap (as if its key | |
290 | # had been decreased to -infinity), and then remove it (as in extract_top) | |
291 | sub delete { | |
292 | my $h = shift; | |
293 | my $v = shift; | |
294 | my $el = $v->heap or return undef; | |
295 | ||
296 | # if there is a parent, cut $el to the top (as if it had just had its | |
297 | # key decreased to a smaller value than $p's value | |
298 | my $p; | |
299 | $p = $el->{p} and ascending_cut $$h, $p, $el; | |
300 | ||
301 | # $el is in the top list now, make it look like the smallest and | |
302 | # remove it | |
303 | $$h = $el; | |
304 | $h->extract_top; | |
305 | } | |
306 | ||
307 | ||
308 | ################################################# internal utility functions | |
309 | ||
310 | sub elem { | |
311 | my $v = shift; | |
312 | my $el = undef; | |
313 | $el = { | |
314 | p => undef, | |
315 | degree => 0, | |
316 | mark => 0, | |
317 | child => undef, | |
318 | val => $v, | |
319 | left => undef, | |
320 | right => undef, | |
321 | }; | |
322 | $el->{left} = $el->{right} = $el; | |
323 | $v->heap($el); | |
324 | $el; | |
325 | } | |
326 | ||
327 | sub elem_DESTROY { | |
328 | my $el = shift; | |
329 | my $ch; | |
330 | my $next; | |
331 | ||
332 | while( $el ) { | |
333 | $ch = $el->{child} and elem_DESTROY $ch; | |
334 | $next = $el->{right}; | |
335 | ||
336 | $el->{val}->heap(undef); | |
337 | $el->{child} = $el->{right} = $el->{left} = $el->{p} = $el->{val} | |
338 | = undef; | |
339 | $el = $next; | |
340 | } | |
341 | } | |
342 | ||
343 | sub link_to_left_of { | |
344 | my $l = shift; | |
345 | my $r = shift; | |
346 | ||
347 | $l->{right} = $r; | |
348 | $r->{left} = $l; | |
349 | } | |
350 | ||
351 | sub link_as_parent_of { | |
352 | my $p = shift; | |
353 | my $c = shift; | |
354 | ||
355 | my $pc; | |
356 | ||
357 | if( $pc = $p->{child} ) { | |
358 | link_to_left_of $pc->{left}, $c; | |
359 | link_to_left_of $c, $pc; | |
360 | } else { | |
361 | link_to_left_of $c, $c; | |
362 | } | |
363 | $p->{child} = $c; | |
364 | $c->{p} = $p; | |
365 | $p->{degree}++; | |
366 | $c->{mark} = 0; | |
367 | $p; | |
368 | } | |
369 | ||
370 | sub consolidate { | |
371 | my $h = shift; | |
372 | ||
373 | my $cur; | |
374 | my $this; | |
375 | my $next = $$h; | |
376 | my $last = $next->{left}; | |
377 | my @a; | |
378 | do { | |
379 | # examine next item on top list | |
380 | $this = $cur = $next; | |
381 | $next = $cur->{right}; | |
382 | my $d = $cur->{degree}; | |
383 | my $alt; | |
384 | while( $alt = $a[$d] ) { | |
385 | # we already saw another item of the same degree, | |
386 | # put the larger valued one under the smaller valued | |
387 | # one - switch $cur and $alt if necessary so that $cur | |
388 | # is the smaller | |
389 | ($cur,$alt) = ($alt,$cur) | |
390 | if $cur->{val}->cmp( $alt->{val} ) > 0; | |
391 | # remove $alt from the top list | |
392 | link_to_left_of $alt->{left}, $alt->{right}; | |
393 | # and put it under $cur | |
394 | link_as_parent_of $cur, $alt; | |
395 | # make sure that $h still points to a node at the top | |
396 | $$h = $cur; | |
397 | # we've removed the old $d degree entry | |
398 | $a[$d] = undef; | |
399 | # and we now have a $d+1 degree entry to try to insert | |
400 | # into @a | |
401 | ++$d; | |
402 | } | |
403 | # found a previously unused degree | |
404 | $a[$d] = $cur; | |
405 | } until $this == $last; | |
406 | $cur = $$h; | |
407 | for $cur (grep defined, @a) { | |
408 | $$h = $cur if $$h->{val}->cmp( $cur->{val} ) > 0; | |
409 | } | |
410 | } | |
411 | ||
412 | sub ascending_cut { | |
413 | my $top = shift; | |
414 | my $p = shift; | |
415 | my $el = shift; | |
416 | ||
417 | while( 1 ) { | |
418 | if( --$p->{degree} ) { | |
419 | # there are still other children below $p | |
420 | my $l = $el->{left}; | |
421 | $p->{child} = $l; | |
422 | link_to_left_of $l, $el->{right}; | |
423 | } else { | |
424 | # $el was the only child of $p | |
425 | $p->{child} = undef; | |
426 | } | |
427 | link_to_left_of $top->{left}, $el; | |
428 | link_to_left_of $el, $top; | |
429 | $el->{p} = undef; | |
430 | $el->{mark} = 0; | |
431 | ||
432 | # propagate up the list | |
433 | $el = $p; | |
434 | ||
435 | # quit at the top | |
436 | last unless $p = $el->{p}; | |
437 | ||
438 | # quit if we can mark $el | |
439 | $el->{mark} = 1, last unless $el->{mark}; | |
440 | } | |
441 | } | |
442 | ||
443 | ||
444 | 1; | |
445 | ||
446 | __END__ | |
447 | ||
448 | =head1 NAME | |
449 | ||
450 | Heap::Fibonacci - a Perl extension for keeping data partially sorted | |
451 | ||
452 | =head1 SYNOPSIS | |
453 | ||
454 | use Heap::Fibonacci; | |
455 | ||
456 | $heap = Heap::Fibonacci->new; | |
457 | # see Heap(3) for usage | |
458 | ||
459 | =head1 DESCRIPTION | |
460 | ||
461 | Keeps elements in heap order using a linked list of Fibonacci trees. | |
462 | The I<heap> method of an element is used to store a reference to | |
463 | the node in the list that refers to the element. | |
464 | ||
465 | See L<Heap> for details on using this module. | |
466 | ||
467 | =head1 AUTHOR | |
468 | ||
469 | John Macdonald, jmm@perlwolf.com | |
470 | ||
471 | =head1 COPYRIGHT | |
472 | ||
473 | Copyright 1998-2003, O'Reilly & Associates. | |
474 | ||
475 | This code is distributed under the same copyright terms as perl itself. | |
476 | ||
477 | =head1 SEE ALSO | |
478 | ||
479 | Heap(3), Heap::Elem(3). | |
480 | ||
481 | =cut |