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