File Coverage

blib/lib/Tie/Quicksort/Lazy.pm

Criterion	Covered	Total	%
statement	67	72	93.0
branch	20	22	90.9
condition	1	3	33.3
subroutine	11	12	91.6
pod			n/a
total	99	109	90.8

package Tie::Quicksort::Lazy;
@Tie::Quicksort::Lazy::Stable::ISA = qw/ Tie::Quicksort::Lazy /;

use Carp;

use 5.006001;
use strict;
use warnings;

our $VERSION = '0.04';
sub DEBUG() { 0 };

# object field names:
BEGIN {
   my $i = 0;
   for (qw/comparator size ready parts/){  # a coderef, then an arrayref, then an arrayref of arrayrefs.
      eval "sub $_ () {".$i++.'}'
   }
}

our $trivial = 2 ;  # if you want to call sort you have to ask for it

sub import {
	shift; # lose package name
        my %args = @_;
        $trivial = $args{TRIVIAL} || $trivial;
};

sub TIEARRAY{
   my $obj = bless [];
   shift; # lose package name
   if ( ( ref $_[0] ) eq 'CODE' ) {
      $obj->[comparator] = shift
   }else{
      $obj->[comparator] = sub {
 DEBUG and ((defined $_[0] and defined $_[1] ) or Carp::confess "undefined arg to comparator");
 $_[0] cmp $_[1] };
   };

   $obj->[size] = @_;
   $obj->[ready] = [];
   $obj->[parts] = [ [ @_ ] ];  # the stack of unsorted partitions

   return $obj;
};


sub _sort {
   my $obj = shift;
   my $comp_func = $obj->[comparator];
   for(;;){
    my $arr = pop @{$obj->[parts]};
    DEBUG and warn "arr is [ @$arr ]";

    if (@$arr == 1 ) {
      $obj->[ready] = $arr ;
      return
    } elsif (@$arr == 2 ) {
      $obj->[ready] = ( $comp_func->(@$arr) > 0 ? [@$arr[1,0]] : $arr ) ;
      return
    } elsif (@$arr <= $trivial ) {
      $obj->[ready] = [ sort { $comp_func->($a,$b) } @$arr ];
      return
    };
    my (@HighSide, @LowSide) = ();

    # by choosing a random pivot and treating equality differently
    # when examining the before and after parts of the partition,
    # we get stability without scrambling and without any
    # degenerate cases, even contrived ones. (choosing the midpoint
    # gives n*log(n) performance for sorted input, but it would be
    # possible to contrive a quadratic case)

    my $pivot_index = int rand @$arr;

    my $pivot = $arr->[$pivot_index];

    # BEFORE THE PIVOT ELT:
    for ( splice @$arr, 0, $pivot_index ) {
       if ($comp_func->($pivot, $_) < 0 ){
          # we are looking at an elt that belongs after the pivot
          push @HighSide, $_
       }else{
          push @LowSide, $_
       };
    };

    shift @$arr;  # shift off the pivot elt

    # AFTER THE PIVOT ELT:
    for ( @$arr ) {
       if ($comp_func->($pivot, $_) > 0 ){
          # we are looking at an elt that belongs before the pivot
          push @LowSide, $_
       }else{
          push @HighSide, $_
       };
    };

    @HighSide and push @{$obj->[parts]}, \@HighSide; # defer the high side
    push @{$obj->[parts]}, [$pivot]; # this pivot,
    @LowSide and push @{$obj->[parts]}, \@LowSide; # do the low side, if any, next
   } # for (;;)

}


sub FETCHSIZE {
	 $_[0]->[size]
}

sub SHIFT {
    my $obj = shift;
    $obj->[size] or return undef;
    my $rarr = $obj->[ready];

    unless (@$rarr){
        $obj->_sort;
        $rarr = $obj->[ready];
    };

    $obj->[size]-- ;
    shift @$rarr;
}

*STORE = *PUSH = *UNSHIFT = *FETCH =
*STORESIZE = *POP = *EXISTS = *DELETE =
*CLEAR = sub {
   require Carp;
   Carp::croak ('"SHIFT"  and "FETCHSIZE" are the only methods defined for a '.
               __PACKAGE__ . " array");
};

1;
__END__