view release on metacpan or  search on metacpan

lib/Algorithm/NeedlemanWunsch.pm  view on Meta::CPAN

my $from_diag = 1;
my $from_up = 2;
my $from_left = 4;
my $from_diag_idx = 0;
my $from_up_idx = 1;
my $from_left_idx = 2;

sub _curry_callback {
    my ($univ_cb, $spec_name) = @_;

    my $cb;
    if ($spec_name eq 'align') {
        $cb = sub {
	    my $arg = { align => [ @_ ] };
	    my $rv = &$univ_cb($arg);
	    croak "select_align callback returned invalid selection $rv."
	        unless $rv eq 'align';
	};
    } else {
        $cb = sub {
	    my $arg = { $spec_name => $_[0] };
	    my $rv = &$univ_cb($arg);
	    croak "select_align callback returned invalid selection $rv."
	        unless $rv eq $spec_name;
	};
    }

    return $cb;
}

sub _canonicalize_callbacks {
    my $cb;
    if (@_) {
        $cb = $_[0];
    } else {
        $cb = { };
    }

    if (exists($cb->{select_align})) {
        my @cn = qw(align shift_a shift_b);
	foreach (@cn) {
	    if (!exists($cb->{$_})) {
	        $cb->{$_} = _curry_callback($cb->{select_align}, $_);
	    }
	}
    }

    return $cb;
}

sub new {
    my $class = shift;
    my $score_sub = shift;

    my $self = { score_sub => $score_sub, local => 0 };
    if (@_) {
        $self->{gap_penalty} = $_[0];
    }

    return bless $self, $class;
}

sub local {
    my $self = shift;

    if (@_) {
        $self->{local} = $_[0];
    }

    return $self->{local};
}

sub gap_open_penalty {
    my $self = shift;

    if (@_) {
        $self->{gap_open_penalty} = $_[0];
    }

    return $self->{gap_open_penalty};
}

sub gap_extend_penalty {
    my $self = shift;

    if (@_) {
        $self->{gap_extend_penalty} = $_[0];
    }

    return $self->{gap_extend_penalty};
}

sub align {
    my $self = shift;

    my $a = shift;
    my $b = shift;

    $self->{callbacks} = _canonicalize_callbacks(@_);

    if (!exists($self->{gap_open_penalty})) {
	if (exists($self->{gap_extend_penalty})) {
	    croak "gap_open_penalty must be defined together with gap_extend_penalty";
	}

        if (!exists($self->{gap_penalty})) {
	    $self->{gap_penalty} = &{$self->{score_sub}}();
	}

	return $self->_align_basic($a, $b);
    } else {
	if (!exists($self->{gap_extend_penalty})) {
	    croak "gap_extend_penalty must be defined together with gap_open_penalty";
	}

	if ($self->{gap_open_penalty} >= $self->{gap_extend_penalty}) {
	    croak "gap_open_penalty must be smaller than gap_extend_penalty";
	}

	return $self->_align_affine($a, $b);