File Coverage

blib/lib/Text/Dice.pm
Criterion Covered Total %
statement 35 35 100.0
branch 12 14 85.7
condition 6 9 66.6
subroutine 4 4 100.0
pod 1 1 100.0
total 58 63 92.0


line stmt bran cond sub pod time code
1             package Text::Dice;
2              
3 2     2   80113 use strict;
  2         6  
  2         85  
4 2     2   12 use warnings;
  2         3  
  2         66  
5 2     2   3424 use parent qw(Exporter);
  2         1186  
  2         10  
6              
7             our $VERSION = '0.03';
8             $VERSION = eval $VERSION;
9              
10             our @EXPORT = qw(coefficient);
11              
12             sub coefficient {
13 36 50   36 1 25730 return unless 2 == @_;
14              
15 36         84 my ($counts1, $counts2, $pairs1, $pairs2) = (0) x 2;
16 36 100 100     193 if (not ref $_[0] and not ref $_[1]) {
    100 66        
17 34         121 for my $w (split ' ', lc $_[0]) {
18 76         207 $counts1 += length($w) - 1;
19 76         691 ++$pairs1->{substr $w, $_, 2} for (0 .. length($w) - 2);
20             }
21 34         137 for my $w (split ' ', lc $_[1]) {
22 208         283 $counts2 += length($w) - 1;
23 208         1980 ++$pairs2->{substr $w, $_, 2} for (0 .. length($w) - 2);
24             }
25             }
26             elsif ('ARRAY' eq ref $_[0] and 'ARRAY' eq ref $_[1]) {
27 1         3 $counts1 += @{$_[0]};
  1         2  
28 1         3 ++$pairs1->{$_} for @{$_[0]};
  1         10  
29              
30 1         2 $counts2 += @{$_[1]};
  1         3  
31 1         3 ++$pairs2->{$_} for @{$_[1]};
  1         14  
32             }
33 1         6 else { return }
34              
35 35 50 33     178 return 0 unless $counts1 and $counts2;
36              
37 35 100       81 my ($smaller, $larger) = $counts1 > $counts2
38             ? ($pairs2, $pairs1) : ($pairs1, $pairs2);
39              
40 35         40 my $intersection = 0;
41 35         43 while (my ($pair, $count1) = each %{$smaller}) {
  464         1113  
42 429 100       895 my $count2 = $larger->{$pair} or next;
43 315 100       641 $intersection += ($count2 > $count1) ? $count1 : $count2;
44             }
45              
46 35         593 return 2 * $intersection / ($counts1 + $counts2);
47             }
48              
49              
50             1;
51              
52             __END__