File Coverage

blib/lib/Text/WagnerFischer.pm

Criterion	Covered	Total	%
statement	50	58	86.2
branch	18	22	81.8
condition	3	3	100.0
subroutine	6	6	100.0
pod	0	1	0.0
total	77	90	85.5

package Text::WagnerFischer;

use strict;
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $REFC);

$VERSION     = '0.04';
@ISA         = qw(Exporter);
@EXPORT      = ();
@EXPORT_OK   = qw(&distance);
%EXPORT_TAGS = ();

$REFC=[0,1,1];

sub _min {

	my ($first,$second,$third)=@_;
	my $result=$first;

	$result=$second if ($second < $result);
	$result=$third if ($third < $result);

	return $result
}

sub _weight {

	#the cost function

	my ($x,$y,$refc)=@_;

	if ($x eq $y) {

		return $refc->[0] #cost for letter match

	} elsif (($x eq '-') or ($y eq '-')) {

		return $refc->[1] #cost for insertion/deletion operation

	} else {

		return $refc->[2] #cost for letter mismatch
	}
}

sub distance {

	my ($refc,$s,@t)=@_;

	if (!@t) {

		if (ref($refc) ne "ARRAY") {

			if (ref($s) ne "ARRAY") {

				#array cost missing: using default [0,1,1]

				$t[0]=$s;
				$s=$refc;
				$refc=$REFC;

			} else {

	           		require Carp;
        	      		Carp::croak("Text::WagnerFischer: second string is needed");
			}

		} else {

           		require Carp;
       	      		Carp::croak("Text::WagnerFischer: second string is needed");
		}

	} elsif (ref($refc) ne "ARRAY") {

		#array cost missing: using default [0,1,1]

		unshift @t,$s;
		$s=$refc;
		$refc=$REFC;
	}

	my $n=length($s);
	my @result;

	foreach my $t (@t) {

		my @d;

		my $m=length($t);
		if(!$n) {push @result,$m*$refc->[1];next}
		if(!$m) {push @result,$n*$refc->[1];next}

		$d[0][0]=0;

		# original algorithm should be:
		# foreach my $i (1 .. $n) {
		#
		#	my $dist_tmp=0;
		#	foreach my $k (1 .. $i) {$dist_tmp+=_weight(substr($s,$i,1),'-',$refc)}
		#	$d[$i][0]=$dist_tmp;
		# }
		#
		# foreach my $j (1 .. $m) {
		#
		#	my $dist_tmp=0;
		#	foreach my $k (1 .. $j) {$dist_tmp+=_weight('-',substr($t,$j,1),$refc)}
		#	$d[0][$j]=$dist_tmp;
		# }
		# that is:

		foreach my $i (1 .. $n) {$d[$i][0]=$i*$refc->[1];}
		foreach my $j (1 .. $m) {$d[0][$j]=$j*$refc->[1];}

		foreach my $i (1 .. $n) {
			my $s_i=substr($s,$i-1,1);
			foreach my $j (1 .. $m) {

				my $t_i=substr($t,$j-1,1);

				$d[$i][$j]=_min($d[$i-1][$j]+_weight($s_i,'-',$refc),
						 $d[$i][$j-1]+_weight('-',$t_i,$refc),
						 $d[$i-1][$j-1]+_weight($s_i,$t_i,$refc))
			}
		}

		push @result,$d[$n][$m];
	}

	if (wantarray) {return @result} else {return $result[0]}
}

1;

__END__