File Coverage

blib/lib/Lingua/Stem/Cistem.pm

Criterion	Covered	Total	%
statement	124	124	100.0
branch	32	32	100.0
condition	50	59	84.7
subroutine	10	10	100.0
pod	4	4	100.0
total	220	229	96.0

package Lingua::Stem::Cistem;

use strict;
use warnings;

use utf8;

use 5.010001;

require Exporter;

BEGIN {
    $Lingua::Stem::Cistem::VERSION     = '0.07';
    @Lingua::Stem::Cistem::ISA         = qw(Exporter);
    @Lingua::Stem::Cistem::EXPORT      = qw();
    @Lingua::Stem::Cistem::EXPORT_OK   = qw(stem segment stem_robust segment_robust);
    %Lingua::Stem::Cistem::EXPORT_TAGS = (
        'all'            => [qw(stem segment stem_robust segment_robust)],
        'orig'           => [qw(stem segment)],
        'robust'         => [qw(stem_robust segment_robust)],
    );
}

sub stem {
    my $word = shift // '';
    my $case_insensitive = shift;

    my $upper = (ucfirst $word eq $word);

    $word =  lc($word);
    $word =~ tr/äöü/aou/;
    $word =~ s/ß/ss/g;

    $word =~ s/^ge(.{4,})/$1/;

    $word =~ s/sch/\$/g;
    $word =~ s/ei/\%/g;
    $word =~ s/ie/\&/g;
    $word =~ s/(.)\1/$1*/g;

    while(length($word)>3) {
        if( length($word)>5 && ($word =~ s/e[mr]$// || $word =~ s/nd$//) ) {}
        elsif( (!($upper) || $case_insensitive) && $word =~ s/t$//) {}
        elsif( $word =~ s/[esn]$//) {}
        else { last; }
    }

    $word =~ s/(.)\*/$1$1/g;
    $word =~ s/\$/sch/g;
    $word =~ s/\%/ei/g;
    $word =~ s/\&/ie/g;

    return $word;
}

sub segment {
    my $word = shift // '';
    my $case_insensitive = shift;

    my $upper = (ucfirst $word eq $word);

    $word =  lc($word);

    my $original = $word;

    $word =~ s/sch/\$/g;
    $word =~ s/ei/\%/g;
    $word =~ s/ie/\&/g;
    $word =~ s/(.)\1/$1*/g;

    my $suffix_length = 0;

    while(length($word)>3){
        if( length($word)>5 && ($word =~ s/(e[mr])$// || $word =~ s/(nd)$//) ) {
            $suffix_length += 2;
        }
        elsif( (!($upper) || $case_insensitive) && $word =~ s/t$//) {
            $suffix_length++;
        }
        elsif( $word =~ s/([esn])$//) {
            $suffix_length++;
        }
        else{ last; }
    }

    $word =~ s/(.)\*/$1$1/g;

    $word =~ s/\$/sch/g;
    $word =~ s/\%/ei/g;
    $word =~ s/\&/ie/g;

    my $suffix = '';

    if( $suffix_length ) {
        $suffix = substr($original, - $suffix_length);
    }

    return ($word, $suffix);
}

sub stem_robust {
    my $word             = shift // '';
    my $case_insensitive = shift;
    my $keep_ge_prefix   = shift;

    my $ucfirst = (ucfirst $word eq $word);

    $word =  lc($word);
    $word =~ tr/äöü/aou/;
    $word =~ s/([aou])\N{U+0308}/$1/g; # remove U+0308 COMBINING DIAERESIS
    $word =~ s/ß/ss/g;

    $word =~ s/^ge(.{4,})/$1/ unless $keep_ge_prefix;

    $word =~ s/sch/\N{U+0006}/g; # \N{U+0006} ACK
    $word =~ s/ei/\N{U+0007}/g;  # \N{U+0007} BEL
    $word =~ s/ie/\N{U+0008}/g;  # \N{U+0008} BS

    $word =~ s/(.)\1/$1*/g;

    my @graphemes = $word =~ m/\X/g;
    my $length = scalar @graphemes;
    #my $length = scalar (($word =~ m/\X/g)); # does not work

    while($length > 3) {
        if( $length>5 && ($word =~ s/e[mr]$// || $word =~ s/nd$//) ) {$length -= 2;}
        elsif( (!($ucfirst) || $case_insensitive) && $word =~ s/t$//) {$length--;}
        elsif( $word =~ s/[esn]$//) {$length--;}
        else { last; }
    }

    $word =~ s/(.)\*/$1$1/g;

    $word =~ s/\N{U+0006}/sch/g; # \N{U+0006} ACK
    $word =~ s/\N{U+0007}/ei/g;  # \N{U+0007} BEL
    $word =~ s/\N{U+0008}/ie/g;  # \N{U+0008} BS

    return $word;
}


sub segment_robust {
    my $word             = shift // '';
    my $case_insensitive = shift;
    my $keep_ge_prefix   = shift;

    my $ucfirst = (ucfirst $word eq $word);

    $word =  lc($word);
    $word =~ tr/äöü/aou/;
    $word =~ s/([aou])\N{U+0308}/$1/g; # remove U+0308 COMBINING DIAERESIS
    $word =~ s/ß/ss/g;

    my $prefix = '';
    if (!$keep_ge_prefix && $word =~ s/^ge(.{4,})/$1/) {
      $prefix = 'ge';
    }

    my $original = $word;

    $word =~ s/sch/\N{U+0006}/g; # \N{U+0006} ACK
    $word =~ s/ei/\N{U+0007}/g;  # \N{U+0007} BEL
    $word =~ s/ie/\N{U+0008}/g;  # \N{U+0008} BS

    $word =~ s/(.)\1/$1*/g;

    my @graphemes = $word =~ m/\X/g;
    my $length = scalar @graphemes;

    my $suffix_length = 0;

    while($length > 3){
        if( $length > 5 && ($word =~ s/(e[mr])$// || $word =~ s/(nd)$//) ) {
            $suffix_length += 2;
            $length -= 2;
        }
        elsif( (!($ucfirst) || $case_insensitive) && $word =~ s/t$//) {
            $suffix_length++;
            $length--;
        }
        elsif( $word =~ s/([esn])$//) {
            $suffix_length++;
            $length--;
        }
        else{ last; }
    }

    $word =~ s/(.)\*/$1$1/g;

    $word =~ s/\N{U+0006}/sch/g; # \N{U+0006} ACK
    $word =~ s/\N{U+0007}/ei/g;  # \N{U+0007} BEL
    $word =~ s/\N{U+0008}/ie/g;  # \N{U+0008} BS

    my $suffix = '';

    if( $suffix_length ) {
        $suffix = substr($original, - $suffix_length);
    }

    return ($prefix, $word, $suffix);
}

1;
__END__