File Coverage

blib/lib/Text/Util/Chinese.pm

Criterion	Covered	Total	%
statement	125	129	96.9
branch	34	44	77.2
condition	34	40	85.0
subroutine	22	22	100.0
pod	7	9	77.7
total	222	244	90.9

package Text::Util::Chinese;
use strict;
use warnings;
use utf8;

use Exporter 5.57 'import';
use Unicode::UCD qw(charscript);

our $VERSION = '0.07';
our @EXPORT_OK = qw(sentence_iterator phrase_iterator presuf_iterator word_iterator extract_presuf extract_words tokenize_by_script);

use List::Util qw(uniq pairmap);

sub exhaust {
    my ($iter, $cb) = @_;
    my @list;
    while(defined(my $x = $iter->())) {
        push @list, $x;
        $cb->($x) if defined($cb);
    }
    return @list;
}

sub grep_iterator {
    my ($iter, $cb) = @_;
    return sub {
        local $_;
        do {
            $_ = $iter->();
            return undef unless defined($_);
        } while (! $cb->());
        return $_;
    }
}

sub phrase_iterator {
    my ($input_iter, $opts) = @_;
    my @phrases;
    return sub {
        while(! @phrases && defined(my $text = $input_iter->())) {
            @phrases = grep {
                (! /\A\s+\z/) && (! /\p{General_Category=Punctuation}/) && /\p{Han}/
            } split / ( \r?\n | \p{General_Category: Other_Punctuation} )+ /x, $text;
        }
        return shift @phrases;
    }
}

sub sentence_iterator {
    my ($input_iter, $opts) = @_;
    my @sentences;
    return sub {
        while(! @sentences && defined(my $text = $input_iter->())) {
            @sentences = grep { !/\A\s+\z/ } ($text =~
                          m/(
                               (?:
                                   [^\p{General_Category: Open_Punctuation}\p{General_Category: Close_Punctuation}]+?
                               | .*? \p{General_Category: Open_Punctuation} .*? \p{General_Category: Close_Punctuation} .*?
                               )
                               (?: \z | [\n\?\!。？！]+ )
                           )/gx);
        }
        return shift @sentences;
    }
}

sub presuf_iterator {
    my ($input_iter, $opts) = @_;

    my %stats;
    my $threshold = $opts->{threshold} || 9; # an arbitrary choice.
    my $lengths   = $opts->{lengths} || [2,3];

    my $phrase_iter = grep_iterator(
        phrase_iterator( $input_iter ),
        sub { /\A\p{Han}+\z/ }
    );

    my (%extracted, @extracted);
    return sub {
        if (@extracted) {
            return shift @extracted;
        }

        while (!@extracted && defined(my $phrase = $phrase_iter->())) {
            for my $len ( @$lengths ) {
                my $re = '\p{Han}{' . $len . '}';
                next unless length($phrase) >= $len * 2 && $phrase =~ /\A($re) .* ($re)\z/x;
                my ($prefix, $suffix) = ($1, $2);
                $stats{prefix}{$prefix}++ unless $extracted{$prefix};
                $stats{suffix}{$suffix}++ unless $extracted{$suffix};

                for my $x ($prefix, $suffix) {
                    if (! $extracted{$x}
                        && $stats{prefix}{$x}
                        && $stats{suffix}{$x}
                        && $stats{prefix}{$x} > $threshold
                        && $stats{suffix}{$x} > $threshold
                    ) {
                        $extracted{$x} = 1;
                        delete $stats{prefix}{$x};
                        delete $stats{suffix}{$x};

                        push @extracted, $x;
                    }
                }
            }
        }

        if (@extracted) {
            return shift @extracted;
        }

        return undef;
    };
}

sub extract_presuf {
    my ($input_iter, $opts) = @_;
    return [ exhaust(presuf_iterator($input_iter, $opts)) ];
}

sub word_iterator {
    my ($input_iter) = @_;

    my $threshold = 5;
    my (%lcontext, %rcontext, %word, @words);

    my $phrase_iter = grep_iterator(
        phrase_iterator( $input_iter ),
        sub { /\A\p{Han}+\z/ }
    );

    return sub {
        if (@words) {
            return shift @words;
        }

        while (!@words && defined( my $txt = $phrase_iter->() )) {
            my @c = split("", $txt);

            for my $i (0..$#c) {
                if ($i > 0) {
                    $lcontext{$c[$i]}{$c[$i-1]}++;
                    for my $n (2,3) {
                        if ($i >= $n) {
                            my $tok = join('', @c[ ($i-$n+1) .. $i] );
                            unless ($word{$tok}) {
                                if (length($tok) > 1) {
                                    $lcontext{ $tok }{$c[$i - $n]}++;
                                }

                                if ($threshold <= (keys %{$lcontext{$tok}}) && $threshold <= (keys %{$rcontext{$tok}})) {
                                    $word{$tok} = 1;
                                    push @words, $tok;
                                }
                            }
                        }
                    }
                }
                if ($i < $#c) {
                    $rcontext{$c[$i]}{$c[$i+1]}++;
                    for my $n (2,3) {
                        if ($i + $n <= $#c) {
                            my $tok = join('', @c[$i .. ($i+$n-1)]);
                            unless ($word{$tok}) {
                                if (length($tok) > 1) {
                                    $rcontext{ $tok }{ $c[$i+$n] }++;
                                }

                                if ($threshold <= (keys %{$lcontext{$tok}}) && $threshold <= (keys %{$rcontext{$tok}})) {
                                    $word{$tok} = 1;
                                    push @words, $tok;
                                }
                            }
                        }
                    }
                }
            }
        }
        return shift @words;
    }
}

sub extract_words {
    return [ exhaust(word_iterator(@_)) ];
}

sub tokenize_by_script {
    my ($str) = @_;
    my @tokens;
    my @chars = grep { defined($_) } split "", $str;
    return () unless @chars;

    my $t = shift(@chars);
    my $s = charscript(ord($t));
    while(my $char = shift @chars) {
        my $_s = charscript(ord($char));
        if ($_s eq $s) {
            $t .= $char;
        }
        else {
            push @tokens, $t;
            $s = $_s;
            $t = $char;
        }
    }
    push @tokens, $t;
    return grep { ! /\A\s*\z/u } @tokens;
}

1;

__END__