Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Heap::Binary; |
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 | ||
21 | # common names: | |
22 | # h - heap head | |
23 | # i - index of a heap value element | |
24 | # v - user-provided value (to be) stored on the heap | |
25 | ||
26 | ################################################# debugging control | |
27 | ||
28 | my $debug = 0; | |
29 | my $validate = 0; | |
30 | ||
31 | # enable/disable debugging output | |
32 | sub debug { | |
33 | @_ ? ($debug = shift) : $debug; | |
34 | } | |
35 | ||
36 | # enable/disable validation checks on values | |
37 | sub validate { | |
38 | @_ ? ($validate = shift) : $validate; | |
39 | } | |
40 | ||
41 | my $width = 3; | |
42 | my $bar = ' | '; | |
43 | my $corner = ' +-'; | |
44 | my $vfmt = "%3d"; | |
45 | ||
46 | sub set_width { | |
47 | $width = shift; | |
48 | $width = 2 if $width < 2; | |
49 | ||
50 | $vfmt = "%${width}d"; | |
51 | $bar = $corner = ' ' x $width; | |
52 | substr($bar,-2,1) = '|'; | |
53 | substr($corner,-2,2) = '+-'; | |
54 | } | |
55 | ||
56 | ||
57 | sub hdump { | |
58 | my $h = shift; | |
59 | my $i = shift; | |
60 | my $p = shift; | |
61 | my $ch = $i*2+1; | |
62 | ||
63 | return if $i >= @$h; | |
64 | ||
65 | my $space = ' ' x $width; | |
66 | ||
67 | printf( "%${width}d", $h->[$i]->val ); | |
68 | if( $ch+1 < @$h ) { | |
69 | hdump( $h, $ch, $p . $bar); | |
70 | print( $p, $corner ); | |
71 | ++$ch; | |
72 | } | |
73 | if( $ch < @$h ) { | |
74 | hdump( $h, $ch, $p . $space ); | |
75 | } else { | |
76 | print "\n"; | |
77 | } | |
78 | } | |
79 | ||
80 | sub heapdump { | |
81 | my $h; | |
82 | ||
83 | while( $h = shift ) { | |
84 | hdump $h, 0, ''; | |
85 | print "\n"; | |
86 | } | |
87 | } | |
88 | ||
89 | sub heapcheck { | |
90 | my $h; | |
91 | while( $h = shift ) { | |
92 | my $i; | |
93 | my $p; | |
94 | next unless @$h; | |
95 | for( $p = 0, $i = 1; $i < @$h; ++$p, ++$i ) { | |
96 | $h->[$p]->cmp($h->[$i]) <= 0 or die "not in heap order"; | |
97 | last unless ++$i < @$h; | |
98 | $h->[$p]->cmp($h->[$i]) <= 0 or die "not in heap order"; | |
99 | } | |
100 | heapdump $h if $validate >= 2; | |
101 | } | |
102 | } | |
103 | ||
104 | ################################################# forward declarations | |
105 | ||
106 | sub moveto; | |
107 | sub heapup; | |
108 | sub heapdown; | |
109 | ||
110 | ################################################# heap methods | |
111 | ||
112 | # new() usually Heap::Binary->new() | |
113 | # return a new empty heap | |
114 | sub new { | |
115 | my $self = shift; | |
116 | my $class = ref($self) || $self; | |
117 | return bless [], $class; | |
118 | } | |
119 | ||
120 | # add($h,$v) usually $h->add($v) | |
121 | # insert value $v into the heap | |
122 | sub add { | |
123 | my $h = shift; | |
124 | my $v = shift; | |
125 | $validate && do { | |
126 | die "Method 'heap' required for element on heap" | |
127 | unless $v->can('heap'); | |
128 | die "Method 'cmp' required for element on heap" | |
129 | unless $v->can('cmp'); | |
130 | }; | |
131 | heapup $h, scalar(@$h), $v; | |
132 | } | |
133 | ||
134 | # top($h) usually $h->top | |
135 | # the smallest value is returned, but it is still left on the heap | |
136 | sub top { | |
137 | my $h = shift; | |
138 | $h->[0]; | |
139 | } | |
140 | ||
141 | *minimum = \⊤ | |
142 | ||
143 | # extract_top($h) usually $h->extract_top | |
144 | # the smallest value is returned after removing it from the heap | |
145 | sub extract_top { | |
146 | my $h = shift; | |
147 | my $top = $h->[0]; | |
148 | if( @$h ) { | |
149 | # there was at least one item, must decrease the heap | |
150 | $top->heap(undef); | |
151 | my $last = pop(@$h); | |
152 | if( @$h ) { | |
153 | # $top was not the only thing left, so re-heap the | |
154 | # remainder by over-writing position zero (where | |
155 | # $top was) using the value popped from the end | |
156 | heapdown $h, 0, $last; | |
157 | } | |
158 | } | |
159 | $top; | |
160 | } | |
161 | ||
162 | *extract_minimum = \&extract_top; | |
163 | ||
164 | # absorb($h,$h2) usually $h->absorb($h2) | |
165 | # all of the values in $h2 are inserted into $h instead, $h2 is left | |
166 | # empty. | |
167 | sub absorb { | |
168 | my $h = shift; | |
169 | my $h2 = shift; | |
170 | my $v; | |
171 | ||
172 | foreach $v (splice @$h2, 0) { | |
173 | $h->add($v); | |
174 | } | |
175 | $h; | |
176 | } | |
177 | ||
178 | # decrease_key($h,$v) usually $h->decrease_key($v) | |
179 | # the key value of $v has just been decreased and so it may need to | |
180 | # be percolated to a higher position in the heap | |
181 | sub decrease_key { | |
182 | my $h = shift; | |
183 | my $v = shift; | |
184 | $validate && do { | |
185 | die "Method 'heap' required for element on heap" | |
186 | unless $v->can('heap'); | |
187 | die "Method 'cmp' required for element on heap" | |
188 | unless $v->can('cmp'); | |
189 | }; | |
190 | my $i = $v->heap; | |
191 | ||
192 | heapup $h, $i, $v; | |
193 | } | |
194 | ||
195 | # delete($h,$v) usually: $h->delete($v) | |
196 | # delete value $v from heap $h. It must have previously been | |
197 | # add'ed to $h. | |
198 | sub delete { | |
199 | my $h = shift; | |
200 | my $v = shift; | |
201 | $validate && do { | |
202 | die "Method 'heap' required for element on heap" | |
203 | unless $v->can('heap'); | |
204 | die "Method 'cmp' required for element on heap" | |
205 | unless $v->can('cmp'); | |
206 | }; | |
207 | my $i = $v->heap; | |
208 | ||
209 | return $v unless defined $i; | |
210 | ||
211 | if( $i == $#$h ) { | |
212 | pop @$h; | |
213 | } else { | |
214 | my $v2 = pop @$h; | |
215 | if( $v2->cmp($v) < 0 ) { | |
216 | heapup $h, $i, $v2; | |
217 | } else { | |
218 | heapdown $h, $i, $v2; | |
219 | } | |
220 | } | |
221 | $v->heap(undef); | |
222 | return $v; | |
223 | } | |
224 | ||
225 | ||
226 | ################################################# internal utility functions | |
227 | ||
228 | # moveto($h,$i,$v) | |
229 | # place value $v at index $i in the heap $h, and update it record | |
230 | # of where it is located | |
231 | sub moveto { | |
232 | my $h = shift; | |
233 | my $i = shift; | |
234 | my $v = shift; | |
235 | ||
236 | $h->[$i] = $v; | |
237 | $v->heap($i); | |
238 | } | |
239 | ||
240 | # heapup($h,$i,$v) | |
241 | # value $v is to be placed at index $i in heap $h, but it might | |
242 | # be smaller than some of its parents. Keep pushing parents down | |
243 | # until a smaller parent is found or the top of the heap is reached, | |
244 | # and then place $v there. | |
245 | sub heapup { | |
246 | my $h = shift; | |
247 | my $i = shift; | |
248 | my $v = shift; | |
249 | my $pi; # parent index | |
250 | ||
251 | while( $i && $v->cmp($h->[$pi = int( ($i-1)/2 )]) < 0 ) { | |
252 | moveto $h, $i, $h->[$pi]; | |
253 | $i = $pi; | |
254 | } | |
255 | ||
256 | moveto $h, $i, $v; | |
257 | $v; | |
258 | } | |
259 | ||
260 | # heapdown($h,$i,$v) | |
261 | # value $v is to be placed at index $i in heap $h, but it might | |
262 | # have children that are smaller than it is. Keep popping the smallest | |
263 | # child up until a pair of larger children is found or a leaf node is | |
264 | # reached, and then place $v there. | |
265 | sub heapdown { | |
266 | my $h = shift; | |
267 | my $i = shift; | |
268 | my $v = shift; | |
269 | my $leaf = int(@$h/2); | |
270 | ||
271 | while( $i < $leaf ) { | |
272 | my $j = $i*2+1; | |
273 | my $k = $j+1; | |
274 | ||
275 | $j = $k if $k < @$h && $h->[$k]->cmp($h->[$j]) < 0; | |
276 | if( $v->cmp($h->[$j]) > 0 ) { | |
277 | moveto $h, $i, $h->[$j]; | |
278 | $i = $j; | |
279 | next; | |
280 | } | |
281 | last; | |
282 | } | |
283 | moveto $h, $i, $v; | |
284 | } | |
285 | ||
286 | ||
287 | 1; | |
288 | ||
289 | __END__ | |
290 | ||
291 | =head1 NAME | |
292 | ||
293 | Heap::Binary - a Perl extension for keeping data partially sorted | |
294 | ||
295 | =head1 SYNOPSIS | |
296 | ||
297 | use Heap::Binary; | |
298 | ||
299 | $heap = Heap::Binary->new; | |
300 | # see Heap(3) for usage | |
301 | ||
302 | =head1 DESCRIPTION | |
303 | ||
304 | Keeps an array of elements in heap order. The I<heap> method | |
305 | of an element is used to store the index into the array that | |
306 | refers to the element. | |
307 | ||
308 | See L<Heap> for details on using this module. | |
309 | ||
310 | =head1 AUTHOR | |
311 | ||
312 | John Macdonald, jmm@perlwolf.com | |
313 | ||
314 | =head1 COPYRIGHT | |
315 | ||
316 | Copyright 1998-2003, O'Reilly & Associates. | |
317 | ||
318 | This code is distributed under the same copyright terms as perl itself. | |
319 | ||
320 | =head1 SEE ALSO | |
321 | ||
322 | Heap(3), Heap::Elem(3). | |
323 | ||
324 | =cut |