File Coverage

blib/lib/Binary/Heap/Array.pm
Criterion Covered Total %
statement 171 181 94.4
branch 47 58 81.0
condition 12 19 63.1
subroutine 28 29 96.5
pod 5 19 26.3
total 263 306 85.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             #-------------------------------------------------------------------------------
3             # An extensible array implemented as a binary heap in 100% Pure Perl
4             # Philip R Brenan at gmail dot com, Appa Apps Ltd, 2017
5             #-------------------------------------------------------------------------------
6              
7             package Binary::Heap::Array;
8             require v5.16.0;
9 1     1   471 use warnings FATAL => qw(all);
  1         1  
  1         28  
10 1     1   3 use strict;
  1         1  
  1         13  
11 1     1   3 use Carp;
  1         1  
  1         62  
12 1     1   510 use Data::Table::Text 2017.114 qw(:all);
  1         15916  
  1         212  
13 1     1   7 use Data::Dump qw(dump);
  1         2  
  1         74  
14             our $VERSION = 2017.118;
15              
16             saveToS3('BinaryHeapArray') if 0;
17              
18             #1 Methods
19             sub new() # Create a new binary heap array
20 285     285 1 5320 {return bless []
21             } # new
22              
23             sub subarray ## An array, always a power of 2 wide, containing sub arrays which contain the caller's data or slots which are empty, each of the sub arrays is a power of 2 wide which depends on its position in the array of sub arrays so that all of these arrays make good use of memory provided via a buddy memory allocation system to construct the binary heap array
24 1     1   4 {no overloading;
  1         1  
  1         43  
25 72977   100 72977 0 137597 $_[0][0] //= [] # Field 1
26             }
27             sub inuse :lvalue ## A vec() of bits, the same width as subarray where each bit tells us whether the corresponding sub array is in use or not.
28 1     1   3 {no overloading;
  1         1  
  1         926  
29 106564   66 106564 0 164737 $_[0][1] //= my($v) # Field 2
30             }
31              
32             sub at($$) :lvalue # Address the element at a specified index so that it can get set or got
33 579     579 1 245554 {my ($array, $index) = @_; # Array, index of element
34 579         1172 my $n = $array->size; # Array size
35 579 50 33     2281 return undef if $index < -$n or $index >= $n; # Index out of range
36 579 100       932 return &atUp(@_) if $index >= 0;
37 547         999 &atDown(@_)
38             } # at # It would be nice to use overload @{} here but this requires flattening the array which would be very expensive on large arrays
39              
40             sub pop($) # Pop the topmost element from the leading full array and spread the remainder of its contents as sub arrays of the correct size for each preceding empty slot
41 229     229 1 207 {my ($array) = @_; # Array from which an element is to be popped
42 229         309 my $N = $array->size; # Size of array
43 229 100       346 return undef unless $N; # Cannot pop from an empty array
44 228         253 my $S = $array->subarray; # Sub array list for this array
45 228         242 my $v = \$array->inuse; # Address in use array
46              
47 228         370 for my $i(keys @$S) # Index to each sub array
48 451         319 {my $s = $S->[$i]; # Sub array
49 451 100       652 if (vec($$v, $i, 1)) # Full sub array
50 228         212 {my $pop = CORE::pop @$s; # Pop an element off the first full sub array
51 228         334 for my $I(0..$i-1) # Distribute the remaining elements of this sub array so that each sub array is always a power of two wide which depends on teh position of the sub array in the array of sub arrays
52 223         160 {my $j = 1<<$I;
53 223         154 splice @{$S->[$I]}, 0, $j, splice @$s, -$j, $j; # Copy block across
  223         448  
54 223         448 vec($$v, $I, 1) = 1; # Mark this sub array as in use
55             }
56 228 100       323 if ($N == 1) # We are popping the last element in a binary heap array
57 1         1 {$#{$array->subarray} = -1; # Remove all sub arrays
  1         2  
58 1         2 $$v = ''; # Mark all sub arrays as not in use and shorten the vec() string at the same time
59 1         3 @$S = []; # Empty the array of sub arrays
60             }
61             else # Pop an element that is not the last element in a binary heap array
62 227         371 {vec($$v, $i, 1) = 0; # Mark sub array as not in use
63 227         369 my $W = $array->width; # Active width of array of sub arrays
64 227         265 my $w = containingPowerOfTwo($array->width); # Current width is contained by this power of two
65 227         1625 $$v = substr($$v, 0, 1<<($w-3)); # Keep vec() string length in bounds - the 3 is because there 2**3 bits in a byte as used by vec()
66 227 100       359 splice @$S, 1<<$w if @$S > 1<<$w; # Shorten the array of sub arrays while leaving some room for a return to growth
67 227         413 $S->[$_] = undef for $W..(1<<$w)-1; # Remove outer inactive arrays but keep inner inactive arrays to reduce the allocation rate - the whole point of the inuse array
68             }
69 228         531 return $pop # Return popped element
70             }
71             }
72 0         0 confess "This should not happen" # We have already checked that there is at least one element on the array and so an element can be popped so we should not arrive here
73             } # pop
74              
75             sub push($$) # Push a new element on to the top of the array by accumulating the leading full sub arrays in the first empty slot or create a new slot if none already available
76 34101     34101 1 32090 {my ($array, $element) = @_; # Array, element to push
77 34101         37305 my $S = $array->subarray; # Sub array list
78 34101         34994 my $v = \$array->inuse; # In use status avoiding repeated method call
79 34101 100       37229 if (defined (my $z = $array->firstEmptySubArray)) # First empty sub array will be the target used to hold the results of the push
80 32188         19873 {$#{$S->[$z]} = -1; # Empty target array
  32188         44712  
81 32188         39036 for my $i(reverse 0..$z-1) # Index to each sub array preceding the target array
82 27103         20241 {my $s = $S->[$i]; # Sub array
83 27103 50       34185 if (vec($$v, $i, 1)) # Sub array in use
84 27103         16039 {CORE::push @{$S->[$z]}, @$s; # Push in use sub array
  27103         30778  
85 27103         46504 vec($$v, $i, 1) = 0; # Mark this array as no longer in use
86             }
87             }
88 32188         21570 CORE::push @{$S->[$z]}, $element; # Save element on target array
  32188         29624  
89 32188         40045 vec($$v, $z, 1) = 1; # Mark target array as in use
90             }
91             else # All the current sub arrays are in use
92 1913         2053 {my $w = $array->width; # Current width of array of sub arrays
93 1913         3452 my $W = 1<
94 1913         11780 my $a = $S->[$w] = []; # Create new target sub array
95 1913 50       4007 CORE::push @$a, vec($$v,$_,1) ? @{$S->[$_]} : () for reverse 0..$w-1; # Push all sub arrays onto target
  5900         12912  
96 1913         1823 CORE::push @$a, $element; # Push element onto target
97 1913         6747 vec($$v, $_, 1) = 0 for 0..$w-1; # All original sub arrays are no longer in use
98 1913         2578 vec($$v, $w, 1) = 1; # Newly built target sub array is in use
99 1913         3795 $S->[$_] = undef for $w+1..$W-1; # Pad out array of subs arrays so it is a power of two wide
100             }
101 34101         687680 $array
102             } # push
103              
104             sub size($) # Find the number of elements in the binary heap array
105 1066     1066 1 1044 {my ($array) = @_; # Array
106 1066         1048 my $n = 0; # Element count, width of current sub array
107 1066         1568 my $s = $array->subarray; # Array of sub arrays
108 1066 50 33     4680 if ($s and @$s) # Sub array
109 1066         1666 {my $v = \$array->inuse; # In use status avoiding repeated method call
110 1066         1013 my $p = 1; # Width of current sub array
111 1066         2459 for(0..$#$s) # Each sub array
112 9989 100       13026 {$n += $p if vec($$v, $_, 1); # Add number of elements in this sub array if there are any
113 9989         8281 $p += $p; # Width of next sub array
114             }
115             }
116             $n # Count of elements found
117 1066         1918 } # size
118              
119             sub width($) ## Current width of array of sub arrays where the sub arrays hold data in use
120 36479     36479 0 23341 {my ($array) = @_; # Array
121 36479         21969 my $w = -1; # Width
122 36479         35022 my $s = $array->subarray; # Array of sub arrays
123 36479         34319 my $v = \$array->inuse; # In use status avoiding repeated method call
124 36479 100       49180 for(keys @$s) {$w = $_ if vec($$v, $_, 1)}
  263781         331330  
125 36479         42299 $w + 1 # Count of elements found
126             } # width
127              
128             sub firstEmptySubArray($) ## First unused sub array
129 34101     34101 0 23945 {my ($array) = @_; # Array
130 34101         33400 my $w = $array->width; # Width of array of sub arrays
131 34101         33990 my $v = \$array->inuse; # In use status avoiding repeated method call
132 34101         43933 for(0..$w-1) # Each sub array
133 65191 100       117666 {return $_ unless vec($$v, $_, 1); # First sub array not in use
134             }
135             undef # All sub arrays are in use
136 1913         2974 } # firstEmptySubArray
137              
138             sub firstFullSubArray($) ## First full sub array
139 0     0 0 0 {my ($array) = @_; # Array
140 0         0 my $w = $array->width; # Width of array of sub arrays
141 0         0 my $v = \$array->inuse; # In use status avoiding repeated method call
142 0         0 for(0..$w-1) # Each sub array
143 0 0       0 {return $_ if vec($$v, $_, 1); # First sub array not in use
144             }
145             undef # All sub arrays are in use
146 0         0 } # firstEmptySubArray
147              
148             sub atUp($$) :lvalue ## Get the element at a specified positive index by going up through the array of sub arrays
149 32     32 0 30 {my ($array, $index) = @_; # Array, index of element
150 32         42 my $S = $array->subarray; # Sub array list
151 32         50 my $v = \$array->inuse; # In use status avoiding repeated method call
152 32         74 for my $i(reverse 0..$#$S) # Start with the widest sub array
153 66         60 {my $width = 1 << $i; # Width of array at this position in the array of sub arrays
154 66 100       116 next unless vec($$v, $i, 1);
155 32         30 my $s = $S->[$i]; # Sub array at this position
156 32 50       156 return $s->[$index] if $index < $width; # Get the indexed element from this sub array if possible
157 0         0 $index -= $width; # Reduce the index by the size of this array and move onto the next sub array
158             }
159             undef
160 0         0 } # atUp
161              
162             sub atDown($$) :lvalue ## Get the element at a specified negative index by going down through the array of sub arrays
163 547     547 0 518 {my ($array, $index) = @_; # Array, index of element
164 547         762 my $S = $array->subarray; # Sub array list
165 547         787 my $v = \$array->inuse; # In use status avoiding repeated method call
166 547         1098 for my $i(0..$#$S) # Start with the narrowest sub array
167 3718         2810 {my $width = 1 << $i; # Width of array at this position in the array of sub arrays
168 3718 100       5736 next unless vec($$v, $i, 1);
169 1441         1263 my $s = $S->[$i]; # Sub array at this position
170 1441 100       3666 return $s->[$index] if -$index <= $width; # Get the indexed element from this sub array if possible
171 894         772 $index += $width; # Reduce the index by the size of this array and move onto the next sub array
172             }
173             undef
174 0         0 } # atDown
175              
176             use overload
177 1         8 '@{}'=>\&convertToArray, # So we can process with a for loop
178 1     1   7 '""' =>\&convertToString; # So we can convert to string
  1         1  
179              
180             sub convertToArray($) ## Convert to normal perl array so we can use it in a for loop
181 1     1 0 2 {my ($array) = @_; # Array to convert
182 1         3 my $w = $array->width; # Width of array of sub arrays
183 1         3 my $v = \$array->inuse; # In use status avoiding repeated method call
184 1         2 my @a;
185 1         3 for(reverse 0..$w-1) # Each sub array
186 4 100       7 {next unless vec($$v, $_, 1);
187 2         2 CORE::push @a, @{$array->subarray->[$_]};
  2         9  
188             }
189 1         33 [@a]
190             }
191              
192             sub convertToString($) ## Convert to string
193 10     10 0 12 {my ($array) = @_; # Array to convert
194 10 100       19 if (my $w = $array->width) # Array has content
195 9         11 {my $v = $array->inuse;
196 9 50       37 my $i = $v ? unpack("b*", $v) : '';
197 9         13 my $e = nws(dump($array->subarray));
198 9         12680 __PACKAGE__."(width=$w, inuse=$i, elements=$e)";
199             }
200             else # Array has no content
201 1         20 {__PACKAGE__."(width=0)"
202             }
203             }
204              
205             # Test
206 1 100 66 1 0 561 sub test{eval join('', ) or die $@}
  1 100 100 1 0 27  
  1 100 50 16 0 3  
  1 100   512 0 580  
  1 50   284 0 11927  
  1 100   1   7  
  16 50   1   5850  
  16 50       31  
  16         62  
  16         6816  
  16         5655  
  16         6013  
  512         523  
  512         1119  
  512         2370  
  510         1193  
  510         13979  
  3862         68502  
  2779         4535  
  284         772  
  284         812  
  284         1181  
  284         772  
  284         5023  
  1         2  
  1         4  
  1         17  
  227         3614  
  227         71811  
  1         8  
  1         228  
  1         116  
207              
208             test unless caller;
209              
210             # Documentation
211             #extractDocumentation() unless caller; # Extract the documentation
212              
213             1;
214              
215             =encoding utf-8
216              
217             =head1 Name
218              
219             Binary::Heap::Array - Extensible array each of whose component arrays is an
220             integral power of two wide.
221              
222             =head1 Synopsis
223              
224             my $a = Binary::Heap::Array::new();
225              
226             $a->push(1)->push(2);
227             ok $a->size == 2;
228             ok $a->at( 0) == 1;
229             ok $a->at( 1) == 2;
230             ok $a->at(-1) == 2;
231             ok $a->at(-2) == 1;
232              
233             $a->at(0) = 2;
234             ok $a->at(-2) == 2;
235             ok $a->pop == 2;
236             ok $a->size == 1;
237              
238              
239             =head1 Methods
240              
241             =head2 new()
242              
243             Create a new binary heap Array
244              
245              
246             =head2 at :lvalue($array, $index)
247              
248             Address the element at a specified index so that it can get set or got
249              
250             Parameter Description
251             1 $array Array
252             2 $index index of element
253              
254             =head2 pop($array)
255              
256             Pop the topmost element from the leading full array and spread the remainder of its contents as sub arrays of the correct size for each preceding empty slot
257              
258             Parameter Description
259             1 $array Array from which an element is to be popped
260              
261             =head2 push($array, $element)
262              
263             Push a new element on to the top of the array by accumulating the leading full sub arrays in the first empty slot or create a new slot if none already available
264              
265             Parameter Description
266             1 $array Array
267             2 $element element to push
268              
269             =head2 size($array)
270              
271             Find the number of elements in the binary heap array
272              
273             Parameter Description
274             1 $array Array
275              
276             =head1 Index
277              
278             Alphabetic list of methods:
279              
280             L
281             L
282             L
283             L
284             L
285              
286             =head1 Installation
287              
288             This module is written in 100% Pure Perl in a single file and is thus easy to
289             read, modify and install.
290              
291             Standard Module::Build process for building and installing modules:
292              
293             perl Build.PL
294             ./Build
295             ./Build test
296             ./Build install
297              
298             =head1 See also
299              
300             The arrays used to construct the binary heap array are all an integral power of
301             two wide and thus make good use of the memory allocated by
302             L or similar.
303              
304             =head1 Author
305              
306             philiprbrenan@gmail.com
307              
308             http://www.appaapps.com
309              
310             =head1 Copyright
311              
312             Copyright (c) 2017 Philip R Brenan.
313              
314             This module is free software. It may be used, redistributed and/or modified
315             under the same terms as Perl itself.
316              
317             =cut
318              
319             __DATA__