File Coverage

blib/lib/PDL/ApplyDim.pm

Criterion	Covered	Total	%
statement	56	58	96.5
branch	9	12	75.0
condition	8	10	80.0
subroutine	9	9	100.0
pod	0	2	0.0
total	82	91	90.1

package PDL::ApplyDim;

use v5.36;
our $VERSION = '0.002';
use Carp;
require Exporter;
our @ISA=qw(Exporter);
our @EXPORT=qw(apply_to apply_not_to);
no strict "refs";

sub PDL::apply_to($ndarray, $code, $dims, @extra_args){
    # if code is string, assume it is defined in caller's package
    $code="".caller. "::$code"                      #
	unless ref $code eq 'CODE' || $code =~/::/; #
    return $code->($ndarray->mv($dims, 0), @extra_args)->mv(0,$dims) unless ref $dims;
    return $code->($ndarray->reorder(_shuffle($dims, $ndarray->ndims)),
	    @extra_args)->reorder(_unshuffle($dims, $ndarray->ndims))
	if ref $dims eq "ARRAY";
    croak "Argument $dims is not scalar nor array";
}

*apply_to=\&PDL::apply_to;

sub PDL::apply_not_to($ndarray, $code, $dims, @extra_args){
    # if code is string, assume it is defined in caller's package
    $code="".caller. "::$code"                      #
	unless ref $code eq 'CODE' || $code =~/::/; #
    return $code->($ndarray->mv($dims, -1), @extra_args)->mv(-1,$dims) unless
	ref $dims;
    return $code->($ndarray->reorder(_shuffle_end($dims, $ndarray->ndims)),
	    @extra_args)->reorder(_unshuffle_end($dims, $ndarray->ndims))
	if ref $dims eq "ARRAY";
    croak "Argument $dims is not scalar nor array";
}

*apply_not_to=\&PDL::apply_not_to;


# ancillary routines

# reorder 0..$ndims-1 so @$dims go first
sub _shuffle($dims, $ndims){
    my %seen;
    $seen{$_}++ for my @shuffle=@$dims;
    $seen{$_}||push @shuffle, $_ for 0..$ndims-1;
    return @shuffle;
}

# reorder 0..$ndims-1 so the first dims
# go to positions @$dims. Undo the
# effects of _shuffle

sub _unshuffle($dims, $ndims){
    my %seen;
    my %unshuffle;
    $unshuffle{$dims->[$_]}=$_ for 0..@$dims-1;
    my $count=@$dims;
    (defined $unshuffle{$_}) || ($unshuffle{$_}=$count++) for 0..$ndims-1;
    return @unshuffle{0..$ndims-1};
}

# reorder 0..$ndims-1 so @$dims go last
sub _shuffle_end($dims, $ndims){
    my @shuffle=_shuffle($dims, $ndims);
    return @shuffle[@$dims..$ndims-1, 0..@$dims-1];
}

# reorder 0..$ndims-1 so the last dims
# go to positions @$dims. Undo the
# effects of _shuffle_end

sub _unshuffle_end($dims, $ndims){
    my $division=$ndims-@$dims;
    return map {($_+$division)%$ndims} _unshuffle($dims, $ndims);
}

1;

__END__