WagnerFischer.pm 5.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245
  1. package Text::WagnerFischer;
  2. use strict;
  3. use Exporter;
  4. use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $REFC);
  5. $VERSION = '0.04';
  6. @ISA = qw(Exporter);
  7. @EXPORT = ();
  8. @EXPORT_OK = qw(&distance);
  9. %EXPORT_TAGS = ();
  10. $REFC=[0,1,1];
  11. sub _min {
  12. my ($first,$second,$third)=@_;
  13. my $result=$first;
  14. $result=$second if ($second < $result);
  15. $result=$third if ($third < $result);
  16. return $result
  17. }
  18. sub _weight {
  19. #the cost function
  20. my ($x,$y,$refc)=@_;
  21. if ($x eq $y) {
  22. return $refc->[0] #cost for letter match
  23. } elsif (($x eq '-') or ($y eq '-')) {
  24. return $refc->[1] #cost for insertion/deletion operation
  25. } else {
  26. return $refc->[2] #cost for letter mismatch
  27. }
  28. }
  29. sub distance {
  30. my ($refc,$s,@t)=@_;
  31. if (!@t) {
  32. if (ref($refc) ne "ARRAY") {
  33. if (ref($s) ne "ARRAY") {
  34. #array cost missing: using default [0,1,1]
  35. $t[0]=$s;
  36. $s=$refc;
  37. $refc=$REFC;
  38. } else {
  39. require Carp;
  40. Carp::croak("Text::WagnerFischer: second string is needed");
  41. }
  42. } else {
  43. require Carp;
  44. Carp::croak("Text::WagnerFischer: second string is needed");
  45. }
  46. } elsif (ref($refc) ne "ARRAY") {
  47. #array cost missing: using default [0,1,1]
  48. unshift @t,$s;
  49. $s=$refc;
  50. $refc=$REFC;
  51. }
  52. my $n=length($s);
  53. my @result;
  54. foreach my $t (@t) {
  55. my @d;
  56. my $m=length($t);
  57. if(!$n) {push @result,$m*$refc->[1];next}
  58. if(!$m) {push @result,$n*$refc->[1];next}
  59. $d[0][0]=0;
  60. # original algorithm should be:
  61. # foreach my $i (1 .. $n) {
  62. #
  63. # my $dist_tmp=0;
  64. # foreach my $k (1 .. $i) {$dist_tmp+=_weight(substr($s,$i,1),'-',$refc)}
  65. # $d[$i][0]=$dist_tmp;
  66. # }
  67. #
  68. # foreach my $j (1 .. $m) {
  69. #
  70. # my $dist_tmp=0;
  71. # foreach my $k (1 .. $j) {$dist_tmp+=_weight('-',substr($t,$j,1),$refc)}
  72. # $d[0][$j]=$dist_tmp;
  73. # }
  74. # that is:
  75. foreach my $i (1 .. $n) {$d[$i][0]=$i*$refc->[1];}
  76. foreach my $j (1 .. $m) {$d[0][$j]=$j*$refc->[1];}
  77. foreach my $i (1 .. $n) {
  78. my $s_i=substr($s,$i-1,1);
  79. foreach my $j (1 .. $m) {
  80. my $t_i=substr($t,$j-1,1);
  81. $d[$i][$j]=_min($d[$i-1][$j]+_weight($s_i,'-',$refc),
  82. $d[$i][$j-1]+_weight('-',$t_i,$refc),
  83. $d[$i-1][$j-1]+_weight($s_i,$t_i,$refc))
  84. }
  85. }
  86. push @result,$d[$n][$m];
  87. }
  88. if (wantarray) {return @result} else {return $result[0]}
  89. }
  90. 1;
  91. __END__
  92. =head1 NAME
  93. Text::WagnerFischer - An implementation of the Wagner-Fischer edit distance
  94. =head1 SYNOPSIS
  95. use Text::WagnerFischer qw(distance);
  96. print distance("foo","four");# prints "2"
  97. print distance([0,1,2],"foo","four");# prints "3"
  98. my @words=("four","foo","bar");
  99. my @distances=distance("foo",@words);
  100. print "@distances"; # prints "2 0 3"
  101. @distances=distance([0,2,1],"foo",@words);
  102. print "@distances"; # prints "3 0 3"
  103. =head1 DESCRIPTION
  104. This module implements the Wagner-Fischer dynamic programming technique,
  105. used here to calculate the edit distance of two strings.
  106. The edit distance is a measure of the degree of proximity between two strings,
  107. based on "edits": the operations of substitutions, deletions or insertions
  108. needed to transform the string into the other one (and vice versa).
  109. A cost (weight) is needed for every of the operation defined above:
  110. / a if x=y (cost for letter match)
  111. w(x,y) = | b if x=- or y=- (cost for insertion/deletion operation)
  112. \ c if x!=y (cost for letter mismatch)
  113. These costs are given through an array reference as first argument of the
  114. distance subroutine: [a,b,c].
  115. If the costs are not given, a default array cost is used: [0,1,1] that is the
  116. case of the Levenshtein edit distance:
  117. / 0 if x=y (cost for letter match)
  118. w(x,y) = | 1 if x=- or y=- (cost for insertion/deletion operation)
  119. \ 1 if x!=y (cost for letter mismatch)
  120. This particular distance is the exact number of edit needed to transform
  121. the string into the other one (and vice versa).
  122. When two strings have distance 0, they are the same.
  123. Note that the distance is calculated to reach the _minimum_ cost, i.e.
  124. choosing the most economic operation for each edit.
  125. =head1 EXTENDING (by Daniel Yacob)
  126. New modules may build upon Text::WagnerFischer as a base class.
  127. This is practical when you would like to apply the algorithm
  128. to non-Roman character sets or would like to change some part
  129. of the algorithm but not another.
  130. The following example demonstrates how to use the WagnerFisher
  131. distance algorithm but apply your own weight function in a new
  132. package:
  133. package Text::WagnerFischer::MyModule;
  134. use base qw( Text::WagnerFischer );
  135. #
  136. # Link to the WagnerFisher "distance" function so that the
  137. # new module may also export it:
  138. #
  139. use vars qw(@EXPORT_OK);
  140. @EXPORT_OK = qw(&distance);
  141. *distance = \&Text::WagnerFischer::distance;
  142. #
  143. # "override" the _weight function with the a one:
  144. #
  145. *Text::WagnerFischer::_weight = \&_my_weight;
  146. #
  147. # "override" the default WagnerFischer "costs" table:
  148. #
  149. $Text::WagnerFischer::REFC = [0,2,3,1,1];
  150. sub _my_weight {
  151. :
  152. :
  153. :
  154. }
  155. =head1 AUTHOR
  156. Copyright 2002,2003 Dree Mistrut <F<dree@friul.it>>
  157. This package is free software and is provided "as is" without express
  158. or implied warranty. You can redistribute it and/or modify it under
  159. the same terms as Perl itself.
  160. =head1 SEE ALSO
  161. C<Text::Levenshtein>, C<Text::PhraseDistance>
  162. =cut