#!/usr/bin/perl
#-------------------------------------------------------------------------------
# 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 qw(:all);
use Data::Dump qw(dump);
our $VERSION = 2017.112;

saveToS3('BinaryHeapArray') if 0;

#1 Methods
sub new()                                                                       # Create a new binary heap Array
 {return bless {}
 } # new

sub subarray {$_[0]{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

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

  for my $i(keys @$S)                                                           # Index to each sub array
   {my $s = $S->[$i];                                                           # Sub array
    if ($s and @$s)                                                             # 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
       {for my $j(1..(1<<$I))
         {CORE::unshift @{$S->[$I]}, CORE::pop @$s
         }
       }
      if ($N == 1)                                                              # Pop the last element in a binary heap array
       {$#{$array->subarray} = -1;                                              # Remove all sub arrays
       }
      else                                                                      # Pop an element that is not the last element in a binary heap array
       {$S->[$i] = undef;                                                       # Clear the redistributed array
        my $j = @$S / 2;                                                        # Remove trailing empty slots higher up in the array of sub arrays if by doing so we can make the array of sub arrays a smaller power of two wide
        splice @$S, $j, $j unless grep {!$_ or !@$_} @$S[$j..$#$S];             # Remove trailing empty slots
       }
      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
 {my ($array, $element) = @_;                                                   # Array, element to push
  my $S = $array->subarray;                                                     # Sub array list
  my @a = ($element);                                                           # Accumulate pushed element
  for my $i(keys @$S)                                                           # Index to each sub array
   {my $s = $S->[$i];                                                           # Sub array
    if ($s and @$s)                                                             # Accumulate full sub arrays
     {CORE::unshift @a, @$s;                                                    # Save contents of full sub array
      $S->[$i] = undef;                                                         # Remove this sub array from the sub array list to create
     }
    else                                                                        # Save accumulated entries at first empty slot - it will be a power of two wide
     {$S->[$i] = [@a];
      return $array;
     }
   }
  my $n = @$S;                                                                  # All the arrays have been accumulated, extend the array of sub arrays to hold the accumulated array at the proper position an pad it out to a power of two width with empty slots
  CORE::push @$S, [@a], $n ? ([])x($n-1) : ();                                  # Extend sub array list so that it is always a power of two wide
  $array
 } # push

sub size($)                                                                     # Find the number of elements in the binary heap array
 {my ($array, $element) = @_;                                                   # Array
  my $n = 0; my $p = 1;                                                         # Element count, width of current sub array
  my $s = $array->subarray;                                                     # Sub arrays
  if ($s and @$s)                                                               # Sub array
   {for(@$s)                                                                    # Each sub array
     {$n += $p if $_ and @$_;                                                   # 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 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
  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
    my $s = $S->[$i];                                                           # Sub array at this position
    next unless $s and @$s;                                                     # Skip over empty slots
    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
  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
    my $s = $S->[$i];                                                           # Sub array at this position
    next unless $s and @$s;                                                     # Skip over empty slots
    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

# Test
sub test{eval join('', <Binary::Heap::Array::DATA>) 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

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

=head2 size($array, $element)

Find the number of elements in the binary heap array

     Parameter  Description
  1  $array     Array
  2  $element

=head1 Index

Alphabetic list of methods:

L</at :lvalue($array, $index)>
L</new()()>
L</pop($array)>
L</push($array, $element)>
L</size($array, $element)>

=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<Data::Layout::BuddySystem> or similar.

=head1 Author

philiprbrenan@gmail.com

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__
use utf8;
use Test::More tests=>1076;

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: ". dump($s);

  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: ". dump($_);
   }
 } # checkWidth

sub newArray(;$)                                                                # Push: create an array by pushing
 {my $n = $_[0]//0;
  my $a = Binary::Heap::Array::new();
  $a->push($_-1) for 1..$n;
  checkWidth($a);
  $a
 }

sub pops($)                                                                     # Pop
 {my ($n) = @_;
  my $a = newArray($n);
  for(reverse 0..$n-1)
   {ok $a->pop == $_;
    checkWidth($a);
   }
  ok !defined($a->pop);
  checkWidth($a);
 } # pops

pops(227);

ok  powerOfTwo(1) == 0;                                                         # Power of two
ok  powerOfTwo(2) == 1;
ok !powerOfTwo(3);
ok  powerOfTwo(4) == 2;

ok nws(dump(newArray(  0))) eq nws('bless({ subarray => [] }, "Binary::Heap::Array")');         # Some sample arrays
ok nws(dump(newArray(  1))) eq nws('bless({ subarray => [[0]] }, "Binary::Heap::Array")');
ok nws(dump(newArray(  2))) eq nws('bless({ subarray => [undef, [0, 1]] }, "Binary::Heap::Array")');
ok nws(dump(newArray(  3))) eq nws('bless({ subarray => [[2], [0, 1]] }, "Binary::Heap::Array")');
ok nws(dump(newArray(  9))) eq nws('bless({ subarray => [[8], undef, undef, [0 .. 7]] }, "Binary::Heap::Array")');
ok nws(dump(newArray(127))) eq nws('bless({ subarray => [ [126], [124, 125], [120 .. 123], [112 .. 119], [96 .. 111], [64 .. 95], [0 .. 63], [], ], }, "Binary::Heap::Array")');
ok nws(dump(newArray(253))) eq nws('bless({ subarray => [ [252], undef, [248 .. 251], [240 .. 247], [224 .. 239], [192 .. 223], [128 .. 191], [0 .. 127], ], }, "Binary::Heap::Array")');

for(1..256)                                                                     # All components of the array are a power of two wide so they fit well in a buddy system
 {my $a = newArray($_);
  ok $a->size == $_;
 }

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;
 }

ats($_) for (0..11, 29, 51, 127, 256);

if (1)
 {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;
 }

1
