File Coverage

blib/lib/Algorithm/Loops.pm

Criterion	Covered	Total	%
statement	157	176	89.2
branch	80	94	85.1
condition	16	22	72.7
subroutine	17	19	89.4
pod	8	8	100.0
total	278	319	87.1

package Algorithm::Loops;
# The command "perldoc Algorithm::Loops" will show you the
# documentation for this module.  You can also seach for
# "=head" below to read the unformatted documentation.

use strict;
BEGIN {     # Some still don't have warnings.pm:
    if(  eval { require warnings }  ) {
        warnings->import();
        if(  eval { require warnings::register; }  ) {
            warnings::register->import();
        }
    } else {
        # $^W= 1;
    }
}

require Exporter;
use vars qw( $VERSION @EXPORT_OK );
BEGIN {
    $VERSION= 1.032_00;
    @EXPORT_OK= qw(
        Filter
        MapCar MapCarE MapCarU MapCarMin
        NestedLoops
        NextPermute NextPermuteNum
    );
    { my @nowarn= ( *import, *isa ) }
    *import= \&Exporter::import;
    *isa= \&UNIVERSAL::isa;
}


sub _Type
{
    my( $val )= @_;
    return  ! defined($val) ? "undef" : ref($val) || $val;
}


sub _Croak
{
    my $depth= 1;
    my $sub;
    do {
        ( $sub= (caller($depth++))[3] ) =~ s/.*:://;
    } while(  $sub =~ /^_/  );
    if(   eval { require Carp; 1; }
      &&  defined &Carp::croak  ) {
        unshift @_, "$sub: ";
        goto &Carp::croak;
    }
    die "$sub: ", @_, ".\n";
}


sub Filter(&@)
{
    my( $code, @vals )= @_;
    isa($code,"CODE")  or  _Croak(
        "No code reference given" );
    # local( $_ ); # Done by the loop.
    for(  @vals  ) {
        $code->();
    }
    wantarray ? @vals : join "", @vals;
}


sub MapCarE(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $size= -1;
    for my $av (  @_  ) {
        isa( $av, "ARRAY" )  or  _Croak(
            "Not an array reference (", _Type($av), ")" );
        if(  $size < 0  ) {
            $size= @$av;
        } elsif(  $size != @$av  ) {
            _Croak( "Arrays with different sizes",
                " ($size and ", 0+@$av, ")" );
        }
    }
    my @ret;
    for(  my $i= 0;  $i < $size;  $i++  ) {
        push @ret, &$sub( map { $_->[$i] } @_ );
    }
    return wantarray ? @ret : \@ret;
}


sub MapCarMin(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $min= -1;
    for my $av (  @_  ) {
        isa( $av, "ARRAY" )  or  _Croak(
            "Not an array reference (", _Type($av), ")" );
        $min= @$av   if  $min < 0  ||  @$av < $min;
    }
    my @ret;
    for(  my $i= 0;  $i < $min;  $i++  ) {
        push @ret, &$sub( map { $_->[$i] } @_ );
    }
    return wantarray ? @ret : \@ret;
}


sub MapCarU(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $max= 0;
    for my $av (  @_  ) {
        isa( $av, "ARRAY" )  or  _Croak(
            "Not an array reference (", _Type($av), ")" );
        $max= @$av   if  $max < @$av;
    }
    my @ret;
    for(  my $i= 0;  $i < $max;  $i++  ) {
        push @ret, &$sub( map { $_->[$i] } @_ );
    }
    return wantarray ? @ret : \@ret;
}


sub MapCar(&@)
{
    my $sub= shift(@_);
    isa($sub,"CODE")  or  _Croak(
        "No code reference given" );
    my $max= 0;
    for my $av (  @_  ) {
        isa( $av, "ARRAY" )  or  _Croak(
            "Not an array reference (", _Type($av), ")" );
        $max= @$av   if  $max < @$av;
    }
    my @ret;
    for(  my $i= 0;  $i < $max;  $i++  ) {
        push @ret, &$sub( map { $i < @$_ ? $_->[$i] : () } @_ );
        # If we assumed Want.pm, we could consider an early return.
    }
    return wantarray ? @ret : \@ret;
}


sub NextPermute(\@)
{
    my( $vals )= @_;
    my $last= $#{$vals};
    return !1   if  $last < 1;
    # Find last item not in reverse-sorted order:
    my $i= $last-1;
    $i--   while  0 <= $i  &&  $vals->[$i] ge $vals->[$i+1];
    # If complete reverse sort, we are done!
    if(  -1 == $i  ) {
        # Reset to starting/sorted order:
        @$vals= reverse @$vals;
        return !1;
    }
    # Re-sort the reversely-sorted tail of the list:
    @{$vals}[$i+1..$last]= reverse @{$vals}[$i+1..$last]
        if  $vals->[$i+1] gt $vals->[$last];
    # Find next item that will make us "greater":
    my $j= $i+1;
    $j++  while  $vals->[$i] ge $vals->[$j];
    # Swap:
    @{$vals}[$i,$j]= @{$vals}[$j,$i];
    return 1;
}


sub NextPermuteNum(\@)
{
    my( $vals )= @_;
    my $last= $#{$vals};
    return !1   if  $last < 1;
    # Find last item not in reverse-sorted order:
    my $i= $last-1;
    $i--   while  0 <= $i  &&  $vals->[$i+1] <= $vals->[$i];
    # If complete reverse sort, we are done!
    if(  -1 == $i  ) {
        # Reset to starting/sorted order:
        @$vals= reverse @$vals;
        return !1;
    }
    # Re-sort the reversely-sorted tail of the list:
    @{$vals}[$i+1..$last]= reverse @{$vals}[$i+1..$last]
        if  $vals->[$last] < $vals->[$i+1];
    # Find next item that will make us "greater":
    my $j= $i+1;
    $j++  while  $vals->[$j] <= $vals->[$i];
    # Swap:
    @{$vals}[$i,$j]= @{$vals}[$j,$i];
    return 1;
}


sub _NL_Args
{
    my $loops= shift(@_);
    isa( $loops, "ARRAY" )  or  _Croak(
        "First argument must be an array reference,",
        " not ", _Type($loops) );

    my $n= 1;
    for my $loop (  @$loops  ) {
        if(  ! isa( $loop, "ARRAY" )
         &&  ! isa( $loop, "CODE" )  ) {
            _Croak( "Invalid type for loop $n specification (",
                _Type($loop), ")" );
        }
        $n++;
    }

    my( $opts )= @_;
    if(  isa( $opts, "HASH" )  ) {
        shift @_;
    } else {
        $opts= {};
    }

    my $code;
    if(  0 == @_  ) {
        $code= 0;
    } elsif(  1 != @_  ) {
        _Croak( "Too many arguments" );
    } else {
        $code= pop @_;
        isa($code,"CODE")  or  _Croak(
            "Expected CODE reference not ", _Type($code) );
    }

    my $when= delete($opts->{OnlyWhen})
        ||  sub { @_ == @$loops };
    if(  keys %$opts  ) {
        _Croak( "Unrecognized option(s): ",
            join ' ', keys %$opts );
    }

    return( $loops, $code, $when );
}

sub _NL_Iter
{
    my( $loops, $code, $when )= @_;

    my @list;
    my $i= -1;
    my @idx;
    my @vals= @$loops;

    return  sub { return }
        if  ! @vals;

    return  sub {
        while( 1 ) {
            # Prepare to append one more value:
            if(  $i < $#$loops  ) {
                $idx[++$i]= -1;
                if(  isa( $loops->[$i], 'CODE' )  ) {
                    local( $_ )= $list[-1];
                    $vals[$i]= $loops->[$i]->(@list);
                }
            }
            ## return   if  $i < 0;
            # Increment furthest value, chopping if done there:
            while(  @{$vals[$i]} <= ++$idx[$i]  ) {
                pop @list;
                return   if  --$i < 0;
            }
            $list[$i]= $vals[$i][$idx[$i]];
            my $act;
            $act= !ref($when) ? $when : do {
                local( $_ )= $list[-1];
                $when->(@list);
            };
            return @list   if  $act;
        }
    };

}

sub NestedLoops
{
    my( $loops, $code, $when )= _NL_Args( @_ );

    my $iter= _NL_Iter( $loops, $code, $when );

    if(  ! $code  ) {
        if(  ! defined wantarray  ) {
            _Croak( "Useless in void context",
                " when no code given" );
        }
        return $iter;
    }

    my @ret;
    my @list;
    while(  @list= $iter->()   ) {
        @list= $code->( @list );
        if(  wantarray  ) {
            push @ret, @list;
        } else {
            $ret[0] += @list;
        }
    }
    return wantarray ? @ret : ( $ret[0] || 0 );
}


"Filtering should not be straining";
__END__