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 = \⊤ 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