File Coverage

blib/lib/Acme/Shukugawa/Atom.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

# $Id: /mirror/coderepos/lang/perl/Acme-Shukugawa-Atom/trunk/lib/Acme/Shukugawa/Atom.pm 47728 2008-03-14T01:07:28.622095Z daisuke  $

package Acme::Shukugawa::Atom;
use strict;
use warnings;
use base qw(Class::Accessor::Fast);
use utf8;
use Encode qw(decode_utf8);
use File::ShareDir;
use Text::MeCab;
use YAML ();

our $VERSION = '0.00004';

__PACKAGE__->mk_accessors($_) for qw(custom_words);

# Special case handling -- this could be optimized further
# put it in a sharefile later
our ($CONFIG, @DEFAULT_WORDS, $RE_EXCEPTION, $RE_SMALL, $RE_SYLLABLE, $RE_NBAR);
BEGIN
{
    my $config = YAML::LoadFile(
        $CONFIG || File::ShareDir::module_file(__PACKAGE__, 'config.yaml') );
    $RE_SMALL    = decode_utf8("[ャュョッー]");
    $RE_SYLLABLE = decode_utf8("(?:.$RE_SMALL?)");
    $RE_NBAR     = decode_utf8("^ンー");
    @DEFAULT_WORDS = map {
        (decode_utf8($_->[0]), decode_utf8($_->[1]))
    } @{ $config->{custom_words} || [] };
}

sub _create_exception_re
{
    my $self = shift;
    my $custom = $self->custom_words;

    return decode_utf8(join("|",
        map { $custom->[$_ * 2 + 1] } (0..(scalar(@$custom) - 1)/2) ));
}

sub translate
{
    my $self   = shift;
    my $string = decode_utf8(shift);

    if (! ref $self) {
        $self = $self->new({ custom_words => \@DEFAULT_WORDS, @_ });
    }

    # Create local RE_EXCEPTION
    local $RE_EXCEPTION = $self->_create_exception_re;

    $self->preprocess(\$string);
    $self->runthrough(\$string);
    $self->postprocess(\$string);

    return $string;
}

sub preprocess
{
    my ($self, $strref) = @_;
    my $custom = $self->custom_words;

    for(0..(scalar(@$custom) - 1)/2) {
        my $pattern = $custom->[$_ * 2];
        my $replace = $custom->[$_ * 2 + 1];
        $$strref =~ s/$pattern/$replace/g;
    }
}

sub runthrough
{
    my ($self, $strref) = @_;

    my $mecab = Text::MeCab->new;

    # First, make it all katakana, except for where the surface is already
    # in hiragana
    my $ret = '';

    foreach my $text (split(/($RE_EXCEPTION|\s+)/, $$strref)) {
        if ($text =~ /$RE_EXCEPTION/) {
            $ret .= $text;
            next;
        }

        if ($text !~ /\S/) {
            $ret .= $text;
            next;
        }

        foreach (my $node = $mecab->parse($text); $node; $node = $node->next) {
            next unless $node->surface;

            my $surface = decode_utf8($node->surface);
            my $feature = decode_utf8($node->feature);
            my ($type, $yomi) = (split(/,/, $feature))[0,8];
# warn "$surface -> $type, $yomi";

            if ($surface eq '上手') {
                $ret .= 'マイウー';
                next;
            }

            if ($type eq '動詞' && $node->next) {
                # 助動詞を計算に入れる
                my $next_feature = decode_utf8($node->next->feature);
                my ($next_type, $next_yomi) = (split(/,/, $next_feature))[0,8];
                if ($next_type eq '助動詞') {
                    $yomi .= $next_yomi;
                    $node = $node->next;
                }
            }

            if ($type =~ /副詞|助動詞|形容詞|接続詞|助詞/ && $surface =~ /^\p{InHiragana}+$/) {
                $ret .= $surface;
            } elsif ($yomi) {
                $ret .= $self->atomize($yomi) || $surface;
            } else {
                $ret .= $surface;
            }
        }
    }
    $$strref = $ret;
}

sub postprocess {}

# シースールール
# 寿司→シースー
# ン、が最後だったらひっくり返さない
sub apply_shisu_rule
{
    my ($self, $yomi) = @_;
    return $yomi if $yomi =~ s{^($RE_SYLLABLE)($RE_SYLLABLE)$}{
        my ($a, $b) = ($1, $2);
        $a =~ s/ー$//;
        $b =~ s/ー$//;
        "${b}ー${a}ー";
    }e;
    return;
}

# ワイハールール
# ハワイ→ワイハー
sub apply_waiha_rule
{
    my ($self, $yomi) = @_;

# warn "WAIHA $yomi";
    if ($yomi =~ s/^(${RE_SYLLABLE}[$RE_NBAR]?)([^$RE_NBAR].)$/$2$1/) {
        $yomi =~ s/(^.[^ー].*[^ー])$/$1ー/;
        return $yomi;
    }
    return;
}

# クリビツルール
# びっくり→クリビツ
sub apply_kuribitsu_rule
{
    my ($self, $yomi) = @_;

# warn "KURIBITSU $yomi";
    if ($yomi =~ s/^(${RE_SYLLABLE}.)([^$RE_NBAR]${RE_SYLLABLE}$)/$2$1/) {
        return $yomi;
    }
    return;
}

sub atomize
{
    my ($self, $yomi) = @_;
    $yomi =~ s/ー+/ー/g;

    # Length
    my $word_length = length($yomi);
    my $length = $word_length - ($yomi =~ /$RE_SMALL/g);
    if ($length == 3 && $yomi =~ s/^(${RE_SYLLABLE})ッ/${1}ツ/) {
# warn "Special rule!";
        $length = 4;
    }
    my $done = 0;

# warn "$yomi LENGTH: $length";
    if ($length == 2) {
        my $tmp = $self->apply_shisu_rule($yomi);
        if ($tmp) {
            $yomi = $tmp;
            $done = 1;
        }
    }

    if ($length == 3) {
        my $tmp = $self->apply_waiha_rule($yomi);
        if ($tmp) {
            $yomi = $tmp;
            $done = 1;
        }
    }

    if ($length == 4) { # 4 character words tend to have special xformation
        my $tmp = $self->apply_kuribitsu_rule($yomi);
        if ($tmp) {
            $yomi = $tmp;
            $done = 1;
        }
    }

    if (! $done) {
        $yomi =~ s/(.(?:ー+)?)$//;
        $yomi = $1 . $yomi;
    }

    $yomi =~ s/ッ$/ツ/;
    return $yomi;
}


1;

__END__