File Coverage

blib/lib/Lingua/Stem/Patch/PL.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	52	52	100.0
condition			n/a
subroutine	14	14	100.0
pod	0	8	0.0
total	140	148	94.5

package Lingua::Stem::Patch::PL;

use v5.8.1;
use utf8;
use strict;
use warnings;
use parent 'Exporter';

our $VERSION   = '0.06';
our @EXPORT_OK = qw( stem stem_pl );

*stem_pl = \&stem;

sub stem {
    my $word = lc shift;

    $word = remove_noun($word);
    $word = remove_diminutive($word);
    $word = remove_adjective($word);
    $word = remove_verb($word);
    $word = remove_adverb($word);
    $word = remove_plural($word);
    $word = remove_other($word);

    return $word;
}

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

    if ($length > 6) {
        return $word if $word =~ s{ (?:
            tach
            | acj[aąi]      # -acja -acją -acji
            | [ae]ni[eu]    # -anie -aniu -enie -eniu
            | (?<= ty ) ka  # -tyka → -ty
        ) $}{}x;
    }

    if ($length > 5) {
        return $word if $word =~ s{ (?:
            ach | ami | ce | ta
            | [cn]i[au]        # -cia -ciu -nia -niu
            | (?<= c ) j[aąi]  # -cja -cją -cji → -c
        ) $}{}x;
    }

    return $word;
}

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

    if ($length > 6) {
        return $word if $word =~ s{ (?:
            (?: [aiu]s | [ei]c ) zek  # -aszek -eczek -iczek -iszek -uszek
            | (?<= e[jnr] ) ek        # -ejek -enek -erek → -ej -en -er
        ) $}{}x;
    }

    if ($length > 4) {
        return $word if $word =~ s{
            [ae]k  # -ak -ek
        $}{}x;
    }

    return $word;
}

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

    if ($length > 7) {
        return $1 if $word =~ m{^
            naj                  # naj-
            ( .+ )               # $1
            sz (?: [ey] | ych )  # -sze -szy -szych
        $}x;
    }

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

    if ($length > 5) {
        return $word if $word =~ s{ (?:
            ego | ej | ych
            | ow[aey]  # -owa -owe -owy
        ) $}{}x;
    }

    return $word;
}

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

    if ($length > 5) {
        return $word if $word =~ s{ (?:
            bym | cie | łem
            | [ae] (?: my | sz | ść )  # -amy -emy -asz -esz -aść -eść
        ) $}{}x;
    }

    if ($length > 3) {
        return $word if $word =~ s{ (?:
            ąc
            | a[ćmł]                     # -ać -am -ał
            | e[ćm]                      # -eć -em
            | i[ćł]                      # -ić -ił
            | (?<= a    ) j              # -aj                 → -a
            | (?<= [ae] ) (?: sz | ść )  # -asz -aść -esz -eść → -a -e
        ) $}{}x;
    }

    return $word;
}

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

    if ($length > 4) {
        return $word if $word =~ s{ (?:
              (?<= r    ) ze  # -rze      → -r
            | (?<= [nw] ) ie  # -nie -wie → -n -w
        ) $}{}x;
    }

    return $word;
}

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

    if ($length > 4) {
        return $word if $word =~ s{ (?:
            ami | om | ów
        ) $}{}x;
    }

    return $word;
}

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

    if ($length > 4) {
        return $word if $word =~ s{
            i[ae]  # -ia -ie
        $}{}x;
    }

    if ($length > 3) {
        return $word
            if $word =~ s{ [aąęiłuy] $}{}x;
    }

    return $word;
}

1;

__END__