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