File Coverage

blib/lib/Lingua/Stem/UniNE/CS.pm

Criterion	Covered	Total	%
statement	108	117	92.3
branch	79	120	65.8
condition	9	9	100.0
subroutine	17	17	100.0
pod	0	9	0.0
total	213	272	78.3

package Lingua::Stem::UniNE::CS;

use v5.8.1;
use utf8;
use strict;
use warnings;
use parent 'Exporter';
use Unicode::CaseFold qw( fc );
use Unicode::Normalize qw( NFC );

our $VERSION   = '0.08';
our @EXPORT_OK = qw( stem stem_cs stem_aggressive stem_cs_aggressive );

*stem_cs            = \&stem;
*stem_cs_aggressive = \&stem_aggressive;

sub stem {
    my ($word) = @_;

    $word = NFC fc $word;
    $word = remove_case($word);
    $word = remove_possessive($word);

    return $word;
}

sub stem_aggressive {
    my ($word) = @_;

    $word = NFC fc $word;
    $word = remove_case($word);
    $word = remove_possessive($word);
    $word = remove_comparative($word);
    $word = remove_diminutive($word);
    $word = remove_augmentative($word);
    $word = remove_derivational($word);

    return $word;
}

# remove grammatical case endings from nouns and adjectives
sub remove_case {
    my ($word) = @_;
    my $length = length $word;

    if ($length > 7) {
        return $word
            if $word =~ s{ atech $}{}x;
    }

    if ($length > 6) {
        return $word
            if $word =~ s{ atům $}{}x;

        return palatalize($word)
            if $word =~ s{ (?<= ě ) tem $}{}x;  # -ětem → -ě
    }

    if ($length > 5) {
        return $word
            if $word =~ s{ (?:
                  ými     # -ými
                | am[ai]  # -ama -ami
                | at[ay]  # -ata -aty
                | ov[éi]  # -ové -ovi
                | [áý]ch  # -ách -ých
            ) $}{}x;

        return palatalize($word)
            if $word =~ s{ (?:
                  (?<= [eě]  ) t[ei]  # -ete -eti -ěte -ěti → -e -ě
                | (?<= [éi]  ) mu     # -ému -imu           → -é -i
                | (?<= [eií] ) ch     # -ech -ich -ích      → -e -i -í
                | (?<= [eěí] ) mi     # -emi -ěmi -ími      → -e -ě -í
                | (?<= [éií] ) ho     # -ého -iho -ího      → -é -i -í
            ) $}{}x;
    }

    if ($length > 4) {
        return $word
            if $word =~ s{ (?:
                  at      # -at
                | mi      # -mi
                | us      # -us
                | o[su]   # -os -ou
                | [áůý]m  # -ám -ům -ým
            ) $}{}x;

        return palatalize($word)
            if $word =~ s{ (?:
                  es          # -es
                | [éí]m       # -ém -ím
                | (?<= e ) m  # -em → -e
            ) $}{}x;
    }

    if ($length > 3) {
        return $word
            if $word =~ s{ [aáéouůyý] $}{}x;

        return palatalize($word)
            if $word =~ m{ [eěií] $}x;
    }

    return $word;
}

# remove possesive endings from names
sub remove_possessive {
    my ($word) = @_;

    return $word
        if length $word < 6;

    return $word
        if $word =~ s{ [oů]v $}{}x;  # -ov -ův

    return palatalize($word)
        if $word =~ s{ (?<= i ) n $}{}x;  # -in → -i

    return $word;
}

sub remove_comparative {
    my ($word) = @_;

    return $word
        if length $word < 6;

    return palatalize($word)
        if $word =~ s{ (?<= [eě] ) jš $}{}x;  # -ejš -ějš → -e -ě

    return $word;
}

sub remove_diminutive {
    my ($word) = @_;
    my $length = length $word;

    if ($length > 7) {
        return $word
            if $word =~ s{ oušek $}{}x;
    }

    if ($length > 6) {
        # -aček -áček -anek -ánek -oček -onek -uček -unek
        return $word
            if $word =~ s{ [aáou][čn]ek $}{}x;

        # -eček -éček -enek -ének -iček -íček -inek -ínek → -e -é -i -í
        return palatalize($word)
            if $word =~ s{ (?<= [eéií] ) [čn]ek $}{}x;
    }

    if ($length > 5) {
        # -ačk -áčk -ank -ánk -átk -očk -onk -učk -unk -ušk
        return $word
            if $word =~ s{ (?: [aáou][čn] | át | uš ) k $}{}x;

        # -ečk -éčk -enk -énk -ičk -íčk -ink -ínk
        return palatalize($word)
            if $word =~ s{ [eéií][čn]k $}{}x;
    }

    if ($length > 4) {
        # -ak -ák -ok -uk → -a -á -o -u
        return $word
            if $word =~ s{ (?<= [aáou] ) k $}{}x;

        # -ek -ék -ik -ík → -e -é -i -í
        return palatalize($word)
            if $word =~ s{ (?<= [eéií] ) k $}{}x;
    }

    if ($length > 3) {
        return $word
            if $word =~ s{ k $}{}x;
    }

    return $word;
}

sub remove_augmentative {
    my ($word) = @_;
    my $length = length $word;

    if ($length > 6) {
        return $word
            if $word =~ s{ ajzn $}{}x;
    }

    if ($length > 5) {
        return palatalize($word)
            if $word =~ s{ (?<= i ) (?: sk | zn ) $}{}x;  # -isk -izn → -i
    }

    if ($length > 4) {
        return $word
            if $word =~ s{ ák $}{}x;
    }

    return $word;
}

sub remove_derivational {
    my ($word) = @_;
    my $length = length $word;

    if ($length > 8) {
        return $word
            if $word =~ s{ obinec $}{}x;
    }

    if ($length > 7) {
        # -ovisk -ovišt -ovník -ovstv
        return $word
            if $word =~ s{ ov (?: isk | išt | ník | stv ) $}{}x;

        # -ionář → -i
        return palatalize($word)
            if $word =~ s{ (?<= i ) onář $}{}x;
    }

    if ($length > 6) {
        return $word
            if $word =~ s{ (?:
                ásek | loun | nost | štin | teln |
                ov (?: ec | ík | in | tv )  # -ovec -ovík -ovin -ovtv
            ) $}{}x;

        # -enic -inec -itel → -e -i
        return palatalize($word)
            if $word =~ s{ (?: (?<= e ) nic | (?<= i ) (?: nec | tel ) ) $}{}x;
    }

    if ($length > 5) {
        return $word
            if $word =~ s{ árn $}{}x;

        return palatalize($word)
            if $word =~ s{ (?<= ě ) nk $}{}x;  # -ěnk → -ě

        # -ián -isk -ist -išt -itb → -i -í
        return palatalize($word)
            if $word =~ s{ (?<= i ) (?: án | sk | st | št | tb ) $}{}x;

        # -írn → -í
        return palatalize($word)
            if $word =~ s{ (?<= í ) rn $}{}x;

        # -och -ost -oun -ouš -out -ovn
        return $word
            if $word =~ s{ o (?: ch | st | un | uš | ut | vn ) $}{}x;

        return $word
            if $word =~ s{ (?:
                čan | ctv | kář | kyn | néř | ník | stv | ušk
            ) $}{}x;
    }

    if ($length > 4) {
        # -ač -áč -an -án -ář -as
        return $word
            if $word =~ s{ (?: a[čns] | á[čnř] ) $}{}x;

        # -ec -en -ěn -éř -ic -in -it -iv -ín -íř → -e -ě -é -i -í
        return palatalize($word)
            if $word =~ s{ (?:
                  (?<= e ) [cn]
                | (?<= ě ) n
                | (?<= é ) ř
                | (?<= i ) [cntv]
                | (?<= í ) [nř]
            ) $}{}x;

        # -čk -čn -dl -nk -ob -oň -ot -ov -tk -tv -ul -vk -yn
        return $word
            if $word =~ s{ (?:
                č[kn] | o[bňtv] | t[kv] | [du]l | [nv]k | yn
            ) $}{}x;
    }

    if ($length > 3) {
        return $word
            if $word =~ s{ [cčklnt] $}{}x;
    }

    return $word;
}

sub palatalize {
    my ($word) = @_;

    return $word
        if $word =~ s{ čt[ěií]  $}{ck}x  # -čtě -čti -čtí  → -ck
        || $word =~ s{ št[ěií]  $}{sk}x  # -ště -šti -ští  → -sk
        || $word =~ s{ [cč][ei] $}{k}x   # -ce -ci -če -či → -k
        || $word =~ s{ [zž][ei] $}{h}x;  # -ze -zi -že -ži → -h

    chop $word;

    return $word;
}

1;

__END__