viewvc.cgi/stem-hr/StemHR.pm

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

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

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);

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			sub kgh {
22			my ($pre,$replace,$post) = @_;
23			$replace =~ s/[cè]/k/g;
24			$replace =~ s/[z¾]/g/g;
25			$replace =~ s/[s¹]/h/g;
26	dpavlin	2	return $pre . $replace . $post;
27	dpavlin	1	}
28
29			# samoglasnici
30			my $sa = '[aeiou]';
31			# suglasnici
32			my $su = '[^aeiou]';
33
34	dpavlin	3	my %rules;
35			my %stem_words;
36			my $words = 0;
37			my $stems = 0;
38
39	dpavlin	1	while(<>) {
40			chomp;
41	dpavlin	3	if (/^$/) {
42			print "\n";
43			next;
44			}
45	dpavlin	1
46	dpavlin	3	$words++;
47
48	dpavlin	1	my $orig = $_;
49
50			# imenice
51			# vrsta a
52
53			unless (
54	dpavlin	2	# kgh
55			s/(${sa})([è¾¹czs])(i\|e\|ima)$/kgh($1,$2,' 1')/gex \|\|
56			s/(${sa}[kgh])(a\|u\|om)$/$1 2/g \|\|
57			s/(${su})([è¾¹czs])(i\|e\|ima)$/kgh($1,"a$2",' 3')/gex \|\|
58	dpavlin	1	# nepostojano a
59	dpavlin	2	s/(${su}a{$su})a/$1 4/g \|\|
60			s/(${su})(${su})(a\|u\|i\|e\|om\|ima)$/$1a$2 5/g
61	dpavlin	1	) {
62
63			# mno¾ina
64	dpavlin	2	s/(${su})(ov\|ev)*(i\|a\|ima\|e\|in\|ina)$/$1 6/g;
65	dpavlin	1	# jednina
66	dpavlin	2	s/(o\|e\|a\|u\|om\|em)$/ 7/g;
67	dpavlin	1	}
68
69	dpavlin	3	if (s/^(.+)\s(\d+)$/$1\t$2/g) {
70			$rules{$2}++;
71			$stems++;
72			$stem_words{$1}++;
73			}
74	dpavlin	1
75			printf("%-15s %s\n",$orig,$_);
76	dpavlin	3
77	dpavlin	1	}
78	dpavlin	3	my $nr_stems = keys(%stem_words);
79			printf "\n# %d words, %d stems in %d ops, %.2f%% size\n",$words,$nr_stems,$stems,($nr_stems*100/$words);
80