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