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

#!/usr/bin/perl
#-------------------------------------------------------------------------------
# An extensible array implemented as a binary heap in 100% Pure Perl
# Philip R Brenan at gmail dot com, Appa Apps Ltd, 2017
#-------------------------------------------------------------------------------

package Binary::Heap::Array;
require v5.16.0;
use warnings FATAL => qw(all);
use strict;
use Carp;
use Data::Table::Text 2017.114 qw(:all);
use Data::Dump qw(dump);
our $VERSION = 2017.117;

saveToS3('BinaryHeapArray') if 0;

#1 Methods
sub new()                                                                       # Create a new binary heap array
 {return bless []
 } # new

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
 {no overloading;
  $_[0][0] //= []                                                               # Field 1
 }
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.
 {no overloading;
  $_[0][1] //= my($v)                                                           # Field 2
 }

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 = $array->size;                                                         # 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 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 = $array->size;                                                         # Size of array
  return undef unless $N;                                                       # Cannot pop from an empty array
  my $S = $array->subarray;                                                     # Sub array list for this array
  my $v = \$array->inuse;                                                       # Address in use array

  for my $i(keys @$S)                                                           # Index to each sub array
   {my $s = $S->[$i];                                                           # Sub array
    if (vec($$v, $i, 1))                                                        # Full sub array
     {my $pop = CORE::pop @$s;                                                  # Pop an element off the first full sub array
      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
       {my $j = 1<<$I;
        splice @{$S->[$I]}, 0, $j, splice @$s, -$j, $j;                         # Copy block across
        vec($$v, $I, 1) = 1;                                                    # Mark this sub array as in use
       }
      if ($N == 1)                                                              # We are popping the last element in a binary heap array
       {$#{$array->subarray} = -1;                                              # Remove all sub arrays
        $$v = '';                                                               # Mark all sub arrays as not in use and shorten the vec() string at the same time
        @$S = [];                                                               # Empty the array of sub arrays
       }
      else                                                                      # Pop an element that is not the last element in a binary heap array
       {vec($$v, $i, 1) = 0;                                                    # Mark sub array as not in use
        my $W = $array->width;                                                  # Active width of array of sub arrays
        my $w = containingPowerOfTwo($array->width);                            # Current width is contained by this power of two
        $$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()
        splice @$S, 1<<$w if @$S > 1<<$w;                                       # Shorten the array of sub arrays while leaving some room for a return to growth
        $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
       }
      return $pop                                                               # Return popped element
     }
   }
  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
  my $S = $array->subarray;                                                     # Sub array list
  my $v = \$array->inuse;                                                       # In use status avoiding repeated method call
  if (defined (my $z = $array->firstEmptySubArray))                             # First empty sub array will be the target used to hold the results of the push
   {$#{$S->[$z]} = -1;                                                          # Empty target array
    for my $i(reverse 0..$z-1)                                                  # Index to each sub array preceding the target array
     {my $s = $S->[$i];                                                         # Sub array
      if (vec($$v, $i, 1))                                                      # Sub array in use
       {CORE::push @{$S->[$z]}, @$s;                                            # Push in use sub array
        vec($$v, $i, 1) = 0;                                                    # Mark this array as no longer in use
       }
     }
    CORE::push @{$S->[$z]}, $element;                                           # Save element on target array
    vec($$v, $z, 1) = 1;                                                        # Mark target array as in use
   }
  else                                                                          # All the current sub arrays are in use
   {my $w = $array->width;                                                      # Current width of array of sub arrays
    my $W = 1<
    my $a = $S->[$w] = [];                                                      # Create new target sub array
    CORE::push @$a, vec($$v,$_,1) ? @{$S->[$_]} : () for reverse 0..$w-1;       # Push all sub arrays onto target
    CORE::push @$a, $element;                                                   # Push element onto target
    vec($$v, $_, 1) = 0 for 0..$w-1;                                            # All original sub arrays are no longer in use
    vec($$v, $w, 1) = 1;                                                        # Newly built target sub array is in use
    $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
  my $n = 0;                                                                    # Element count, width of current sub array
  my $s = $array->subarray;                                                     # Array of sub arrays
  if ($s and @$s)                                                               # Sub array
   {my $v = \$array->inuse;                                                     # In use status avoiding repeated method call
    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
     }
   }
  $n                                                                            # Count of elements found
 } # size

sub width($)                                                                    ## Current width of array of sub arrays where the sub arrays hold data in use
 {my ($array) = @_;                                                             # Array
  my $w = -1;                                                                   # Width
  my $s = $array->subarray;                                                     # Array of sub arrays
  my $v = \$array->inuse;                                                       # In use status avoiding repeated method call
  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 = $array->width;                                                        # Width of array of sub arrays
  my $v = \$array->inuse;                                                       # In use status avoiding repeated method call
  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 firstFullSubArray($)                                                        ## First full sub array
 {my ($array) = @_;                                                             # Array
  my $w = $array->width;                                                        # Width of array of sub arrays
  my $v = \$array->inuse;                                                       # In use status avoiding repeated method call
  for(0..$w-1)                                                                  # Each sub array
   {return $_ if 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
  my $S = $array->subarray;                                                     # Sub array list
  my $v = \$array->inuse;                                                       # In use status avoiding repeated method call
  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
  my $S = $array->subarray;                                                     # Sub array list
  my $v = \$array->inuse;                                                       # In use status avoiding repeated method call
  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
 '@{}'=>\&convertToArray,                                                       # So we can process with a for loop
 '""' =>\&convertToString;                                                      # So we can convert to string

sub convertToArray($)                                                           ## Convert to normal perl array so we can use it in a for loop
 {my ($array) = @_;                                                             # Array to convert
  my $w = $array->width;                                                        # Width of array of sub arrays
  my $v = \$array->inuse;                                                       # In use status avoiding repeated method call
  my @a;
  for(reverse 0..$w-1)                                                          # Each sub array
   {next unless vec($$v, $_, 1);
    CORE::push @a, @{$array->subarray->[$_]};
   }
  [@a]
 }

sub convertToString($)                                                          ## Convert to string
 {my ($array) = @_;                                                             # Array to convert
  if (my $w = $array->width)                                                    # Array has content
   {my $v = $array->inuse;
    my $i = $v ? unpack("b*", $v) : '';
    my $e = nws(dump($array->subarray));
    __PACKAGE__."(width=$w, inuse=$i, elements=$e)";
   }
  else                                                                          # Array has no content
   {__PACKAGE__."(width=0)"
   }
 }

# Test
sub test{eval join('', ) or die $@}

test unless caller;

# Documentation
#extractDocumentation() unless caller;                                          # Extract the documentation

1;

=encoding utf-8

=head1 Name

 Binary::Heap::Array - Extensible array each of whose component arrays is an
 integral power of two wide.

=head1 Synopsis

  my $a = Binary::Heap::Array::new();

  $a->push(1)->push(2);
  ok $a->size   == 2;
  ok $a->at( 0) == 1;
  ok $a->at( 1) == 2;
  ok $a->at(-1) == 2;
  ok $a->at(-2) == 1;

     $a->at(0)  =  2;
  ok $a->at(-2) == 2;
  ok $a->pop    == 2;
  ok $a->size   == 1;


=head1 Methods

=head2 new()

Create a new binary heap Array


=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
  2  $index     index of element

=head2 pop($array)

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

     Parameter  Description
  1  $array     Array from which an element is to be popped

=head2 push($array, $element)

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

     Parameter  Description
  1  $array     Array
  2  $element   element to push

=head2 size($array)

Find the number of elements in the binary heap array

     Parameter  Description
  1  $array     Array

=head1 Index

Alphabetic list of methods:

L
L
L
L
L

=head1 Installation

This module is written in 100% Pure Perl in a single file and is thus easy to
read, modify and install.

Standard Module::Build process for building and installing modules:

  perl Build.PL
  ./Build
  ./Build test
  ./Build install

=head1 See also

The arrays used to construct the binary heap array are all an integral power of
two wide and thus make good use of the memory allocated by
L or similar.

=head1 Author

[e-mail]

http://www.appaapps.com

=head1 Copyright

Copyright (c) 2017 Philip R Brenan.

This module is free software. It may be used, redistributed and/or modified
under the same terms as Perl itself.

=cut

__DATA__