viewvc.cgi/stem-hr/StemHR.pm

#!/usr/bin/perl -w
#
# Croatian stemmer
#

# promjenjive:
# - imenice
# - pridjevi
# - brojevi
# - zamjenice
# - prilozi
# - glagoli
#
# nepromjenjive:
# - prijedlozi
# - veznici
# - èestice
# - uzvici
#

use strict;

sub kgh {
        my ($pre,$replace,$post) = @_;
        $replace =~ s/[cè]/k/g;
        $replace =~ s/[z¾]/g/g;
        $replace =~ s/[s¹]/h/g;
        return $pre . $replace . $post;
}

# samoglasnici
my $sa = '[aeiou]';
# suglasnici
my $su = '[^aeiou]';

my %rules;
my %stem_words;
my $words = 0;
my $stems = 0;

while(<>) {
        chomp;
        if (/^$/) {
                print "\n";
                next;
        }

        $words++;

        my $orig = $_;

        # imenice
        # vrsta a

        unless (
                # kgh
                s/(${sa})([è¾¹czs])(i|e|ima)$/kgh($1,$2,' 1')/gex ||
                s/(${sa}[kgh])(a|u|om)$/$1 2/g ||
                s/(${su})([è¾¹czs])(i|e|ima)$/kgh($1,"a$2",' 3')/gex ||
                # nepostojano a
                s/(${su}a{$su})a/$1 4/g ||
                s/(${su})(${su})(a|u|i|e|om|ima)$/$1a$2 5/g
        ) {

                # mno¾ina
                s/(${su})(ov|ev)*(i|a|ima|e|in|ina)$/$1 6/g;
                # jednina
                s/(o|e|a|u|om|em)$/ 7/g;
        }

        if (s/^(.+)\s(\d+)$/$1\t$2/g) {
                $rules{$2}++;
                $stems++;
                $stem_words{$1}++;
        }

        printf("%-15s %s\n",$orig,$_);

}
my $nr_stems = keys(%stem_words);
printf "\n# %d words, %d stems in %d ops, %.2f%% size\n",$words,$nr_stems,$stems,($nr_stems*100/$words);

foreach my $s (keys %stem_words) {
        print "#stem $stem_words{$s} $s\n";
}

foreach my $r (keys %rules) {
        print "#rule $rules{$r} $r\n";
}
1	dpavlin	1	#!/usr/bin/perl -w
2			#
3			# Croatian stemmer
4			#
5
6			# promjenjive:
7			# - imenice
8			# - pridjevi
9			# - brojevi
10			# - zamjenice
11			# - prilozi
12			# - glagoli
13			#
14			# nepromjenjive:
15			# - prijedlozi
16			# - veznici
17			# - èestice
18			# - uzvici
19			#
20
21	dpavlin	4	use strict;
22
23	dpavlin	1	sub kgh {
24			my ($pre,$replace,$post) = @_;
25			$replace =~ s/[cè]/k/g;
26			$replace =~ s/[z¾]/g/g;
27			$replace =~ s/[s¹]/h/g;
28	dpavlin	2	return $pre . $replace . $post;
29	dpavlin	1	}
30
31			# samoglasnici
32			my $sa = '[aeiou]';
33			# suglasnici
34			my $su = '[^aeiou]';
35
36	dpavlin	3	my %rules;
37			my %stem_words;
38			my $words = 0;
39			my $stems = 0;
40
41	dpavlin	1	while(<>) {
42			chomp;
43	dpavlin	3	if (/^$/) {
44			print "\n";
45			next;
46			}
47	dpavlin	1
48	dpavlin	3	$words++;
49
50	dpavlin	1	my $orig = $_;
51
52			# imenice
53			# vrsta a
54
55			unless (
56	dpavlin	2	# kgh
57			s/(${sa})([è¾¹czs])(i\|e\|ima)$/kgh($1,$2,' 1')/gex \|\|
58			s/(${sa}[kgh])(a\|u\|om)$/$1 2/g \|\|
59			s/(${su})([è¾¹czs])(i\|e\|ima)$/kgh($1,"a$2",' 3')/gex \|\|
60	dpavlin	1	# nepostojano a
61	dpavlin	2	s/(${su}a{$su})a/$1 4/g \|\|
62			s/(${su})(${su})(a\|u\|i\|e\|om\|ima)$/$1a$2 5/g
63	dpavlin	1	) {
64
65			# mno¾ina
66	dpavlin	2	s/(${su})(ov\|ev)*(i\|a\|ima\|e\|in\|ina)$/$1 6/g;
67	dpavlin	1	# jednina
68	dpavlin	2	s/(o\|e\|a\|u\|om\|em)$/ 7/g;
69	dpavlin	1	}
70
71	dpavlin	3	if (s/^(.+)\s(\d+)$/$1\t$2/g) {
72			$rules{$2}++;
73			$stems++;
74			$stem_words{$1}++;
75			}
76	dpavlin	1
77			printf("%-15s %s\n",$orig,$_);
78	dpavlin	3
79	dpavlin	1	}
80	dpavlin	3	my $nr_stems = keys(%stem_words);
81			printf "\n# %d words, %d stems in %d ops, %.2f%% size\n",$words,$nr_stems,$stems,($nr_stems*100/$words);
82
83	dpavlin	4	foreach my $s (keys %stem_words) {
84			print "#stem $stem_words{$s} $s\n";
85			}
86
87			foreach my $r (keys %rules) {
88			print "#rule $rules{$r} $r\n";
89			}