1package Heap::Binary;
2
3use strict;
4use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
5
6require Exporter;
7require AutoLoader;
8
9@ISA = qw(Exporter AutoLoader);
10
11# No names exported.
12# No names available for export.
13@EXPORT = ( );
14
15$VERSION = '0.71';
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
28my $debug = 0;
29my $validate = 0;
30
31# enable/disable debugging output
32sub debug {
33    @_ ? ($debug = shift) : $debug;
34}
35
36# enable/disable validation checks on values
37sub validate {
38    @_ ? ($validate = shift) : $validate;
39}
40
41my $width = 3;
42my $bar = ' | ';
43my $corner = ' +-';
44my $vfmt = "%3d";
45
46sub 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
57sub 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
80sub heapdump {
81    my $h;
82
83    while( $h = shift ) {
84	hdump $h, 0, '';
85	print "\n";
86    }
87}
88
89sub 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
106sub moveto;
107sub heapup;
108sub heapdown;
109
110################################################# heap methods
111
112# new()                 usually Heap::Binary->new()
113#	return a new empty heap
114sub 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
122sub 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
136sub top {
137    my $h = shift;
138    $h->[0];
139}
140
141*minimum = \&top;
142
143# extract_top($h)          usually $h->extract_top
144#	the smallest value is returned after removing it from the heap
145sub 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.
167sub 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
181sub 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.
198sub 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
231sub 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.
245sub 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.
265sub 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
2871;
288
289__END__
290
291=head1 NAME
292
293Heap::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
304Keeps an array of elements in heap order.  The I<heap> method
305of an element is used to store the index into the array that
306refers to the element.
307
308See L<Heap> for details on using this module.
309
310=head1 AUTHOR
311
312John Macdonald, jmm@perlwolf.com
313
314=head1 COPYRIGHT
315
316Copyright 1998-2003, O'Reilly & Associates.
317
318This code is distributed under the same copyright terms as perl itself.
319
320=head1 SEE ALSO
321
322Heap(3), Heap::Elem(3).
323
324=cut
325