package Lingua::Stem::It;
use strict;
use Exporter;
use Carp;
use vars qw (@ISA @EXPORT_OK @EXPORT %EXPORT_TAGS $VERSION);
BEGIN {
@ISA = qw (Exporter);
@EXPORT = ();
@EXPORT_OK = qw (stem stem_word clear_stem_cache stem_caching);
%EXPORT_TAGS = ();
}
$VERSION = "0.02";
my $Stem_Caching = 0;
my $Stem_Cache = {};
sub stem {
return [] if ($#_ == -1);
my $parm_ref;
if (ref $_[0]) {
$parm_ref = shift;
} else {
$parm_ref = { @_ };
}
my $words = [];
my $locale = 'it';
my $exceptions = {};
foreach (keys %$parm_ref) {
my $key = lc ($_);
if ($key eq '-words') {
@$words = @{$parm_ref->{$key}};
} elsif ($key eq '-exceptions') {
$exceptions = $parm_ref->{$key};
} elsif ($key eq '-locale') {
$locale = $parm_ref->{$key};
} else {
croak (__PACKAGE__ . "::stem() - Unknown parameter '$key' with value '$parm_ref->{$key}'\n");
}
}
local( $_ );
foreach (@$words) {
# Flatten case
$_ = lc $_;
# Check against exceptions list
if (exists $exceptions->{$_}) {
$_ = $exceptions->{$_};
next;
}
# Check against cache of stemmed words
my $original_word = $_;
if ($Stem_Caching && exists $Stem_Cache->{$original_word}) {
$_ = $Stem_Cache->{$original_word};
next;
}
$_ = stem_word($_);
$Stem_Cache->{$original_word} = $_ if $Stem_Caching;
}
$Stem_Cache = {} if ($Stem_Caching < 2);
return $words;
}
sub stem_word {
our($word) = @_;
my @suffix;
$word = lc $word;
# Check against cache of stemmed words
if ($Stem_Caching && exists $Stem_Cache->{$word}) {
return $Stem_Cache->{$word};
}
our($RV, $R1, $R2);
#### First, replace all acute accents by grave accents.
$word =~ s/é/è/g;
### put u after q, and u, i between vowels into upper case.
$word =~ s/([aàeèiìoòuù])([ui])([aàeèiìoòuù])/$1.uc($2).$3/eg;
#### RV is defined as follows
$RV = $word;
#### If the second letter is a consonant,
if($word =~ /^.[^aàeèiìoòuù]/) {
#### RV is the region after the next following vowel
$RV =~ s/^..[^aàeèiìoòuù]*[aàeèiìoòuù]//;
#### or if the first two letters are vowels
} elsif ($word =~ /^[aàeèiìoòuù][^aàeèiìoòuù]/) {
#### RV is the region after the next consonant
$RV =~ s/^..[aàeèiìoòuù]*[^aàeèiìoòuù]//;
#### and otherwise (consonant-vowel case)
} else {
#### RV is the region after the third letter
$RV =~ s/^...//;
}
#print "RV=$RV\n";
#### Defining R1 and R2
$R1 = $word;
#### R1 is the region after the first non-vowel following a
#### vowel, or is the null region at the end of the word if
#### there is no such non-vowel.
unless($R1 =~ s/^.*?[aàeèiìoòuù][^aàeèiìoòuù]//) {
$R1 = "";
}
#print "R1=$R1\n";
#### R2 is the region after the first non-vowel following a
#### vowel in R1, or is the null region at the end of the
#### word if there is no such non-vowel.
$R2 = $R1;
if($R2) {
unless($R2 =~ s/^.*?[aàeèiìoòuù][^aàeèiìoòuù]//) {
$R2 = "";
}
}
#print "R2=$R2\n";
#### Step 0: Attached pronoun
##### Search for the longest among the following suffixes
my @pronoun = qw(
ci gli la le li lo mi ne si ti vi
sene gliela gliele glieli glielo gliene
mela mele meli melo mene
tela tele teli telo tene
cela cele celi celo cene
vela vele veli velo vene
);
#### following one of
#### (a) ando endo
#### (b) ar er ir
#### in RV.
#### In case of (a) the suffix is deleted,
#### in case (b) it is replace by e
stem_killer( $RV, "[ae]ndo", "", @pronoun )
or stem_killer( $RV, "[aei]r", "e", @pronoun );
#### Step 1: Standard suffix removal
my $step1 = 0;
#### Search for the longest among the following suffixes,
#### and perform the action indicated
@suffix = qw(
anza anze
ico ici ica ice iche ichi
ismo ismi
abile abili ibile ibili
ista iste isti istà istè istì
oso osi osa ose
mente
atrice atrici
);
#### delete if in R2
$step1 += stem_killer( $R2, "", "", @suffix );
@suffix = qw(
icazione icazioni icatore icatori
azione azioni atore atori
);
#### delete if in R2
#### if preceded by ic, delete if in R2
$step1 += stem_killer( $R2, "", "", @suffix );
@suffix = qw(
logia logie
);
#### replace with log if in R2
$step1 += stem_killer( $R2, "", "log", @suffix );
@suffix = qw(
uzione uzioni usione usioni
);
#### replace with u if in R2
$step1 += stem_killer( $R2, "", "u", @suffix );
@suffix = qw(
enza enze
);
#### replace with ente if in R2
$step1 += stem_killer( $R2, "", "ente", @suffix );
@suffix = qw(
amento amenti imento imenti
);
#### delete if in RV
$step1 += stem_killer( $RV, "", "", @suffix );
@suffix = qw(
amente
);
#### delete if in R1
#### if preceded by iv, delete if in R2
#### (and if further preceded by at, delete if in R2), otherwise,
#### if preceded by os, ic or abil, delete if in R2
$step1 += stem_killer( $R2, "ativ", "", @suffix )
|| stem_killer( $R2, "iv", "", @suffix )
|| stem_killer( $R2, "(os|ic|abil)", "", @suffix )
|| stem_killer( $R1, "", "", @suffix );
@suffix = qw(
ità
);
#### delete if in R2
#### if preceded by abil, ic or iv, delete if in R2
$step1 += stem_killer( $R2, "(abil|ic|iv)", "", @suffix )
|| stem_killer( $R2, "", "", @suffix );
@suffix = qw(
ivo ivi iva ive
);
#### delete if in R2
#### if preceded by at, delete if in R2
#### (and if further preceded by ic, delete if in R2)
$step1 += stem_killer( $R2, "icat", "", @suffix)
|| stem_killer( $R2, "at", "", @suffix)
|| stem_killer( $R2, "", "", @suffix);
#### Step 2: Verb suffixes
#### Do step 2 if no ending was removed by step 1.
if($step1 == 0) {
#### Search for the longest among the following suffixes in RV,
#### and if found, delete.
stem_killer( $RV, "", "", qw(
ammo ando ano are arono asse assero assi assimo
ata ate ati ato ava avamo avano avate avi avo
emmo enda ende endi endo erà erai eranno ere
erebbe erebbero erei eremmo eremo ereste eresti
erete erò erono essero ete eva evamo evano evate
evi evo Yamo iamo immo irà irai iranno ire
irebbe irebbero irei iremmo iremo ireste iresti
irete irò irono isca iscano isce isci isco iscono
issero ita ite iti ito iva ivamo ivano ivate
ivi ivo ono uta ute uti uto ar er
));
}
#### Step 3a
#### Delete a final a, e, i, o, à, è, ì or ò if it is in RV,
#### and a preceding i if it is in RV
if($RV =~ s/i?[aeioàèìò]$//) {
$word =~ s/i?[aeioàèìò]$//;
#} else {
# if($RV =~ s/[aeioàèìò]$//) {
# $word =~ s/[aeioàèìò]$//;
# }
}
#### Step 3b
#### Replace final ch (or gh) with c (or g) if in RV
if($RV =~ s/([cg])h$/$1/) {
$word =~ s/([cg])h$/$1/;
}
#### Finally,
#### turn I and U back into lower case
$word =~ s/([IU])/lc($1)/eg;
return $word;
}
sub stem_killer {
my($where, $pre, $with, @list) = @_;
use vars qw($RV $R1 $R2 $word);
my $done = 0;
foreach my $P (sort { length($b) <=> length($a) } @list) {
if($where =~ /$pre$P$/) {
$R2 =~ s/$pre$P$/$with/;
$R1 =~ s/$pre$P$/$with/;
$RV =~ s/$pre$P$/$with/;
$word =~ s/$pre$P$/$with/;
$done = 1;
last;
}
}
return $done;
}
sub stem_caching {
my $parm_ref;
if (ref $_[0]) {
$parm_ref = shift;
} else {
$parm_ref = { @_ };
}
my $caching_level = $parm_ref->{-level};
if (defined $caching_level) {
if ($caching_level !~ m/^[012]$/) {
croak(__PACKAGE__ . "::stem_caching() - Legal values are '0','1' or '2'. '$caching_level' is not a legal value");
}
$Stem_Caching = $caching_level;
}
return $Stem_Caching;
}
sub clear_stem_cache {
$Stem_Cache = {};
}
1;
__END__
=head1 NAME
Lingua::Stem::It - Porter's stemming algorithm for Italian
=head1 SYNOPSIS
use Lingua::Stem::It;
my $stems = Lingua::Stem::It::stem({ -words => $word_list_reference,
-locale => 'it',
-exceptions => $exceptions_hash,
});
my $stem = Lingua::Stem::It::stem_word( $word );
=head1 DESCRIPTION
This module applies the Porter Stemming Algorithm to its parameters,
returning the stemmed words.
The algorithm is implemented exactly (I hope :-) as described in:
http://snowball.tartarus.org/algorithms/italian/stemmer.html
The code is carefully crafted to work in conjunction with the L<Lingua::Stem>
module by Benjamin Franz, from which I've also borrowed some functionalities
(caching and exception list).
=head1 METHODS
=over 4
=item stem({ -words => \@words, -locale => 'it', -exceptions => \%exceptions });
Stems a list of passed words. Returns an anonymous list reference to the stemmed
words.
Example:
my $stemmed_words = Lingua::Stem::It::stem({ -words => \@words,
-locale => 'it',
-exceptions => \%exceptions,
});
=item stem_word( $word );
Stems a single word and returns the stem directly.
Example:
my $stem = Lingua::Stem::It::stem_word( $word );
=item stem_caching({ -level => 0|1|2 });
Sets the level of stem caching.
'0' means 'no caching'. This is the default level.
'1' means 'cache per run'. This caches stemming results during a single
call to 'stem'.
'2' means 'cache indefinitely'. This caches stemming results until
either the process exits or the 'clear_stem_cache' method is called.
=item clear_stem_cache;
Clears the cache of stemmed words
=back
=cut
=head2 EXPORT
None by default.
=head1 AUTHOR
Aldo Calpini, dada@perl.it
=head1 SEE ALSO
Lingua::Stem
=head1 COPYRIGHT
Copyright (c) Aldo Calpini, dada@perl.it. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut