I think I'm getting the hang of threading, but I'd appreciate if someone could
double check me. I'm interested in speed, but also is it in good PDL style?
I need to calculate 'closeness' scores for each location in a 2 dimensional
piddle .
For example, given the piddle
[
[1 0 0 1]
[0 0 0 0]
[0 1 1 0]
[0 0 1 0]
[0 0 1 1]
]
The weights should be
[
[10 8 8 10]
[ 9 9 9 9]
[ 8 10 10 8]
[ 7 9 10 9]
[ 6 8 10 10]
]
Every time I got a hit, then it's score 10. The cell above and below the hit
is scored 9, the cell above and below that is 8 and so on.
This is the routine that I've come up with:
sub calcscore {
my $f = $_[0];
my @score = @{ $_[1] };
# create a new piddle to store the results, the same size as the input
my $r = zeroes dims $f;
# record the width of the piddle.
my $max = ( dims $f)[1] - 1;
#create an empty array of piddles of the right size
my @got;
@got[ 2 * ( scalar @score - 1 ) ] = undef;
# $got[0] is those which are hits
$got[0] = whichND( $f != 0 );
for my $i ( 1 .. scalar @score ) {
$got[$i] = null;
my $tmp = null;
my $new = null;
my $change = null;
#calculate $got[+1] as those where the hit is 1 above
$tmp .= $got[ $i - 1 ];
$tmp->slice('1')--;
# remove those which have gone off the edge
$change = $tmp->slice('1') >= 0;
$got[$i] .=
$tmp->where( $change->dummy( 1, 2 )->transpose )
->reshape( 2, $change->sum );
$got[ -$i ] = null;
$tmp = null;
$new = null;
$change = null;
#repeat for -1 where the hit is 1 below, and the other edge
$tmp .= $got[ -$i + 1 ];
$tmp->slice('1')++;
$change .= $tmp->slice('1') <= $max;
$got[ -$i ] .=
$tmp->where( $change->dummy( 1, 2 )->transpose )
->reshape( 2, $change->sum );
}
# use the @got's to score each item. I do it in reverse so that
# the overwrites are correcting earlier further aways
foreach my $i ( reverse( 0 .. scalar @score ) ) {
my $res = $r->indexND( $got[$i] );
$res .= $score[$i];
$res = $r->indexND( $got[ -$i ] );
$res .= $score[$i];
}
return $r;
}
_______________________________________________
Perldl mailing list
[email protected]
http://mailman.jach.hawaii.edu/mailman/listinfo/perldl
