use warnings;
use strict;

{    my $text = "this is the text to search";
    my $index = parseText($text);
    print getScore($index, ['this', 'search']) ."\n";
        # this prints about ~17, terms are 4 words appart
}

{    my $text = "and this is some more text";
    my $index = parseText($text);
    print getScore($index, ['this', 'text']) ."\n";
        # this prints about ~23, terms are only 3 words appart
}

sub getScore {
    my ($index, $words) = @_;
    my ($score, $num_words);

    foreach my $word (@$words) {
        unless ($index->{$word}) {  return -1  }
        $score += 1 + (1 - 1/scalar @{ $index->{$word} });
        $num_words++;
    }
    return $score if $num_words <= 1;

    my $proximities = getMinProx_PS($index, $words);
    my $prox_count    = 1/1.5;
    my $prox_bonus    = 0;
    foreach my $prox (@$proximities) {
        $prox_count *= 1.5;
        $prox_bonus = (100/(($prox->[1] - $prox->[0] + 1)/$num_words)*
+*1.7)/$prox_count**2;
        last if $prox_bonus < 0.01;
        $score += $prox_bonus;
    }
    return $score;
}

sub getMinProx_PS {
    my ($index, $keywords) = @_;
    my (@cur_list, @minimal);

    foreach my $keyword (@$keywords) {
        return undef unless ref $index->{$keyword};
        push @cur_list, [shift @{ $index->{$keyword} }, $keyword];
    }
    @cur_list = sort {$a->[0] <=> $b->[0]} @cur_list;

    while (1) {
        if (scalar @{$index->{ $cur_list[0][1] }} == 0) {
            push @minimal, [$cur_list[0][0], $cur_list[-1][0]];
            last;
        }
        my $p = [shift @{$index->{ $cur_list[0][1] }}, $cur_list[0][1]
+];
        my $q = [$cur_list[1][0], $cur_list[1][1]];

        if ($p->[0] > $cur_list[-1][0]) {
            push @minimal, [$cur_list[0][0], $cur_list[-1][0]];
            shift @cur_list;  push @cur_list, $p;
        } else {
            $cur_list[0] = $p;
            @cur_list = sort {$a->[0] <=> $b->[0]} @cur_list;
        }
    }

    @minimal = sort {$a->[1] - $a->[0] <=> $b->[1] - $b->[0]} @minimal
+;
    return \@minimal;
}

sub parseText {
    my $text = shift;

    my (%word_index, $word_count);
    while ($text =~ m/(\w+)/g) {
        push @{$word_index{lc $1}}, ++$word_count;
    }

    return \%word_index;
}
[download]