File Coverage

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

Criterion	Covered	Total	%
statement	72	72	100.0
branch	35	36	97.2
condition			n/a
subroutine	15	15	100.0
pod	0	7	0.0
total	122	130	93.8

package Lingua::Stem::UniNE::DE;

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_de stem_aggressive stem_de_aggressive );

*stem_de            = \&stem;
*stem_de_aggressive = \&stem_aggressive;

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

    $word = NFC fc $word;
    $word = remove_plural($word);

    return $word;
}

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

    $word = NFC fc $word;
    $word = aggressive_diacritic($word);
    $word = aggressive_step1($word);
    $word = aggressive_step2($word);

    return $word;
}

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

    return $word
        if $length < 5;

    $word = remove_diacritic($word);

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

    if ($length > 5) {
        return $word
            if $word =~ s{ (?: e[nrs] | se ) $}{}x;  # -en -er -es -se
    }

    return $word
        if $word =~ s{ [enrs] $}{}x;  # -e -n -r -s

    return $word;
}

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

    $word =~ tr{äöü}{aou};

    return $word;
}

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

    for ($word) {
        #tr{áàâä}{a};
        tr{áàâä}{a};
        tr{íìîï}{i};
        tr{óòôö}{o};
        tr{úùûü}{u};
    }

    return $word;
}

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

    if ($length > 5) {
        return $word
            if $word =~ s{ ern $}{}x;  # -ern
    }

    if ($length > 4) {
        return $word
            if $word =~ s{ e[mnrs] $}{}x;  # -em -en -er -es
    }

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

        return $word
            if $word =~ s{ (?<= [bdfghklmnt] ) s $}{}x;  # -s
    }

    return $word;
}

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

    if ($length > 5) {
        return $word
            if $word =~ s{ est $}{}x;  # -est
    }

    if ($length > 4) {
        return $word
            if $word =~ s{ e[nr] $}{}x;  # -en -er

        return $word
            if $word =~ s{ (?<= [bdfghklmnt] ) st $}{}x;  # -st
    }

    return $word;
}

1;

__END__