Binary-Heap-Array
view release on metacpan or search on metacpan
lib/Binary/Heap/Array.pm view on Meta::CPAN
sub speedNo{$speedNo} # Speed number
$code
END
eval $s; # Generate and optimise the package
$@ and confess $@;
}
#1 Methods
sub new(*) # Create a new binary heap array. A string of flags enables optimizations to the base version, which uses the minimum amount of memory at all times, to use more memory t...
{my ($flags) = @_; # Optimization flags ipsw in any order surrounding quotes are not necessary
my $f = $flags;
my $name = 'Binary::Heap::Array::';
for(@speedChars) # Generate package name matching requested optimisations
{if ($f =~ m/$_/i)
{ $f =~ s/$_//gi;
$name .= uc($_);
}
else
{$name .= lc($_);
lib/Binary/Heap/Array.pm view on Meta::CPAN
confess unless speedSize;
$array->[5] //= (my $v = 0) # Field 6
}
sub currentWidth :lvalue ## The current width of the array
{my ($array) = @_;
no overloading;
confess unless speedWidth;
$array->[6] //= (my $v = 0) # Field 7
}
sub at($$) :lvalue # Address the element at a specified index so that it can get set or got
{my ($array, $index) = @_; # Array, index of element
my $n = size($array); # Array size
return undef if $index < -$n or $index >= $n; # Index out of range
return &atUp(@_) if $index >= 0;
&atDown(@_)
} # at # It would be nice to use overload @{} here but this requires flattening the array which would be very expensive on large arrays
sub inUseVector ($) :lvalue ## Sub arrays in use
{my ($array) = @_;
return inUse($array) if speedInUse;
my $v = '';
my @a = @{subarray($array)};
vec($v, $_, 1) = !!$a[$_] for 0..$#a;
$v
}
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
{my ($array) = @_; # Array from which an element is to be popped
my $N = size($array); # Size of array
return undef unless $N; # Cannot pop from an empty array
if (speedPp) # Fast with pre and post
{my $element = at($array, -1);
post($array)++;
currentSize($array)-- if speedSize; # Decrease cached size of array if possible - has to be done late to avoid confusion over at
return $element;
}
lib/Binary/Heap/Array.pm view on Meta::CPAN
currentWidth($array) = $w+1 # New width of array of sub arrays
if speedWidth and currentWidth($array) <= $w;
}
return $pop # Return popped element
}
} # for each subarray
}
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
} # pop
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
{my ($array, $element) = @_; # Array, element to push
currentSize($array)++ if speedSize; # Increase cached size of array if possible
if (speedPp and my $p = post($array)) # Allow for post
{if (size($array)) # Quick push
{post($array)--;
at($array, -1) = $element;
}
else # Push first element
{post($array) = pre($array) = 0; @{subarray($array)} = ();
lib/Binary/Heap/Array.pm view on Meta::CPAN
else
{$S->[$_] = undef for 0..$w-1; # All original sub arrays are no longer in use
}
currentWidth($array) = $w+1 if speedWidth and currentWidth($array) <= $w; # Cache new width if possible and greater
$S->[$_] = undef for $w+1..$W-1; # Pad out array of subs arrays so it is a power of two wide
}
}
$array
} # push
sub size($) # Find the number of elements in the binary heap array
{my ($array) = @_; # Array
return currentSize($array) if speedSize; # Use cached size if possible
my $n = 0; # Element count, width of current sub array
my $s = subarray($array); # Array of sub arrays
if ($s and @$s) # Sub array
{my $v = inUseVector($array); # Sub arrays in use
my $p = 1; # Width of current sub array
for(0..$#$s) # Each sub array
{$n += $p if vec($v, $_, 1); # Add number of elements in this sub array if there are any
$p += $p; # Width of next sub array
}
}
if (speedPp)
{my $p = pre($array); # Allow for pre and post
my $q = post($array);
return $n - $p - $q # Count of elements found with modifications from pre and post
}
$n # Count of elements found
} # size
sub shift($) # Remove and return the current first element of the array
{my ($array) = @_; # Array
my $n = size($array); # Size of array
return undef unless $n; # Use cached size if possible
my $element = at($array, 0); # Check that there is a first element
if (speedPp)
{pre($array)++; # Skip over the first element
currentSize($array)-- if speedSize; # Decrease cached size of array if possible
}
else # Pop all elements and then push then on again one level down
{my @a; # save area for array
CORE::unshift @a, $array->pop for 0..$n-1; # Undo the existing array
shift @a; # Remove the shifted element
$array->push($_) for @a; # Restore each element one place down
}
$element # Return successfully removed element
} # shift
sub unshift($$) # Insert an element at the start of the array
{my ($array, $element) = @_; # Array, element to be inserted
if (speedPp and pre($array))
{pre($array)--; # Skip over the existing preceding element
currentSize($array)++ if speedSize; # Increase cached size of array if possible
at($array, 0) = $element; # Insert new element
}
elsif (speedPp) # Add a new sub array
{my $w = width($array);
if (speedInUse)
lib/Binary/Heap/Array.pm view on Meta::CPAN
currentSize($array)++ if speedSize; # Increase cached size of array if possible
}
else # Pop all elements and then push then on again one level down
{my @a; # Save area for array
CORE::unshift @a, $array->pop for 0..size($array)-1; # Undo the existing array
$array->push($_) for $element, @a; # Place new element followed by existing elements
}
$array # Return array so we can chain operations
} # unshift
sub width($) ## Current width of array of sub arrays where the sub arrays hold data in use
{my ($array) = @_; # Array
return currentWidth($array) if speedWidth; # Use cached width if possible
my $w = -1; # Width
my $s = subarray($array); # Array of sub arrays
my $v = inUseVector($array); # Sub arrays in use
for(keys @$s) {$w = $_ if vec($v, $_, 1)}
$w + 1 # Count of elements found
} # width
sub firstEmptySubArray($) ## First unused sub array
{my ($array) = @_; # Array
my $w = width($array); # Width of array of sub arrays
my $v = inUseVector($array); # Sub arrays in use
for(0..$w-1) # Each sub array
{return $_ unless vec($v, $_, 1); # First sub array not in use
}
undef # All sub arrays are in use
} # firstEmptySubArray
sub atUp($$) :lvalue ## Get the element at a specified positive index by going up through the array of sub arrays
{my ($array, $index) = @_; # Array, index of element
$index += pre($array) if speedPp; # Allow for pre and post
my $S = subarray($array); # Sub array list
my $v = inUseVector($array); # Sub arrays in use
for my $i(reverse 0..$#$S) # Start with the widest sub array
{my $width = 1 << $i; # Width of array at this position in the array of sub arrays
next unless vec($v, $i, 1);
my $s = $S->[$i]; # Sub array at this position
return $s->[$index] if $index < $width; # Get the indexed element from this sub array if possible
$index -= $width; # Reduce the index by the size of this array and move onto the next sub array
}
undef
} # atUp
sub atDown($$) :lvalue ## Get the element at a specified negative index by going down through the array of sub arrays
{my ($array, $index) = @_; # Array, index of element
$index -= post($array) if speedPp; # Allow for pre and post
my $S = subarray($array); # Sub array list
my $v = inUseVector($array); # Sub arrays in use
for my $i(0..$#$S) # Start with the narrowest sub array
{my $width = 1 << $i; # Width of array at this position in the array of sub arrays
next unless vec($v, $i, 1);
my $s = $S->[$i]; # Sub array at this position
return $s->[$index] if -$index <= $width; # Get the indexed element from this sub array if possible
$index += $width; # Reduce the index by the size of this array and move onto the next sub array
}
undef
} # atDown
use overload # Operator overloading
'@{}'=>\&convertToArray, # So we can process with a for loop
'""' =>\&convertToString, # So we can convert to string
'eq' =>\= # Check whether two arrays are equal
sub convertToArray($) ## Convert to normal perl array so we can use it in a for loop
{my ($array) = @_; # Array to convert
my $w = width($array); # Width of array of sub arrays
my $v = inUseVector($array); # Sub arrays in use
my @a;
for(reverse 0..$w-1) # Each sub array
{next unless vec($v, $_, 1);
my $a = subarray($array)->[$_];
CORE::push @a, @{subarray($array)->[$_]};
}
if (speedPp) # Allow for pre and post
{my $p = pre($array);
my $q = post($array);
splice @a, 0, $p if $p;
splice @a, -$q, $q if $q;
}
[@a]
}
sub unpackVector($) # Unpack the in use vector
{my ($array) = @_;
my $v = inUseVector($array);
$v ? unpack("b*", $v) : ''
}
sub convertToString($) ## Convert to string
{my ($array) = @_; # Array to convert
my $e = sub
{my $a = subarray($array);
return '' unless $a and @$a;
'subarrays='.nws(dump($a))
}->();
my $i = sub # Array has inUse vector
{return "inUse=".unpackVector($array).', ' if speedInUse && width($array);
lib/Binary/Heap/Array.pm view on Meta::CPAN
my $w = sub # Width of array of sub arrays
{my $w = width($array);
return "width=$w, " if $w;
'';
}->();
__PACKAGE__."($s$w$p$i$e)" # String representation of array
}
sub equals($$) ## Equals check whether two arrays are equal
{my ($A, $B) = @_; # Arrays to check
my $nA = $A->size;
my $nB = $B->size;
return 0 unless $nA == $nB; # Different sized arrays cannot be equal
for(0..$nA-1) # Check each element
{return 0 unless $A->at($_) eq $B->at($_);
}
1
}
END
lib/Binary/Heap/Array.pm view on Meta::CPAN
ok $a->size == 1;
$a->unshift(2);
ok $a->size == 2;
$a->unshift(1);
ok $a->size == 3;
=head1 Methods
=head2 new($flags)
sub new(*) # Create a new binary heap array. A string of flags enables optimizations to the base version, which uses the minimum amount of memory at all times, to use more memory t...
Parameter Description
1 $flags Optimization flags ipsw in any order surrounding quotes are not necessary
=head2 at :lvalue($array, $index)
Address the element at a specified index so that it can get set or got
Parameter Description
1 $array Array
lib/Binary/Heap/Array.pm view on Meta::CPAN
under the same terms as Perl itself.
=cut
__DATA__
use Test::More tests=>186237;
sub debug{0} # 0 - no debug, 1 - do debug
our @optimisations; # All combinations of optimizations
my $speed; # The name of the package to test
sub checkWidth($) # Check that all the arrays used in the construction of this binary heap array are a power of two in width
{my ($array) = @_; # Array to check
my $s = $array->subarray; # Sub arrays
return unless $s and @$s; # Empty array is OK
!defined(powerOfTwo(scalar @$s)) # The array must either be empty or a power of two in width
and confess "The width of this array of sub arrays is not a power of two: $array";
for(@$s) # Each sub array
{next unless $_ and @$_; # Empty array is OK
!defined(powerOfTwo(scalar @$_)) # The array must either be empty or a power of two in width
and confess "The width of this sub array is not a power of two: $array";
}
} # checkWidth
sub newArray($) # Push: create an array by pushing
{my $number = $_[0]//0;
my $array = Binary::Heap::Array::new($speed); # Request an array with the desired optimizations
$array->push($_-1) for 1..$number;
checkWidth($array);
$array
}
sub ats($) # At
{my ($n) = @_;
my $a = newArray($n);
ok $a->at(0) == 0 if $n;
ok $a->at(1) == 1 if $n > 1;
ok $a->at(-1) == $n-1 if $n;
ok $a->at($_-$n) == $_ for 0..$n-1;
}
sub pops($) # Pop
{my ($n) = @_;
my $a = newArray($n);
for(reverse 0..$n-1)
{ok $a->pop == $_;
ok $a->size == $_;
checkWidth($a);
}
ok !defined($a->pop);
checkWidth($a);
} # pops
sub shifts($) # Shift
{my ($n) = @_;
my $a = newArray($n);
for(0..$n-1)
{ok $a->shift == $_;
ok $a->size == $n - $_ - 1;
checkWidth($a);
}
ok !defined($a->pop);
checkWidth($a);
} # shifts
( run in 0.376 second using v1.01-cache-2.11-cpan-65fba6d93b7 )