File Coverage

blib/lib/Lingua/LA/Stemmer.pm

Criterion	Covered	Total	%
statement	25	33	75.7
branch	11	20	55.0
condition			n/a
subroutine	2	2	100.0
pod	0	1	0.0
total	38	56	67.8

package Lingua::LA::Stemmer;

use strict;
our $VERSION = '0.01';

our %que_words = map {$_=>1} qw( atque quoque neque itaque absque apsque abusque
adaeque adusque denique deque susque oblique peraeque plenisque
quandoque quisque quaeque cuiusque cuique quemque quamque quaque
quique quorumque quarumque quibusque quosque quasque quotusquisque
quousque ubique undique usque uterque utique utroque utribique torque
coque concoque contorque detorque decoque excoque extorque obtorque
optorque retorque recoque attorque incoque intorque praetorque );

our @noun_adj_suffix = qw( ibus ius ae am as em es ia is nt os ud um
us a e i o u );

our @verb_suffix = qw( iuntur beris erunt untur iunt mini ntur stis
bor ero mur mus ris sti tis tur unt bo ns nt ri m r s t );

our %verb_suffix_transform_dict = qw( iuntur i erunt i untur i iunt i
 unt i beris bi bor bi bo bi ero eri );

sub stem {
    my @words = ref($_[0]) ? @{$_[0]} : @_ ;
    my @stems;
    my $suffix;

  STEM:
    foreach my $word ( @words ){

	# converts jv to iu
	$word =~ tr/jv/iu/;

	# removes '-que'
	if( $word =~ /que$/o ){
	    if( $que_words{$word} ){
		push @stems, $word;
		next STEM;
	    }
	    else{
		$word =~ s/que$//o;
	    }
	}

	for $suffix ( @noun_adj_suffix ){
	    if( $word =~ /$suffix$/ ){
		if(length( $word ) - length ($suffix) >= 2){
		    $word =~ s/$suffix$//;
		    push @stems, $word;
		}
		else {
		    push @stems, $word;
		}
		next STEM;
	    }
	}

	for $suffix ( @verb_suffix ){
	    if( $word =~ /$suffix$/ ){
		if( $word =~ /$suffix$/ ){
		    foreach my $term (keys %verb_suffix_transform_dict){
			if( $word =~ s/$term$/$verb_suffix_transform_dict{$term}/ ){
			    last;
			}
		    }
		    if(length( $word ) - length ($suffix) >= 2){
			$word =~ s/$suffix$//;
			push @stems, $word;
		    }
		    else {
			push @stems, $word;
		    }
		    next STEM;
		}
	    }
	}
        push @stems, $word;
    }
    wantarray ? @stems : \@stems;
}

1;
__END__