File Coverage

blib/lib/Lingua/ZH/MMSEG.pm

Criterion	Covered	Total	%
statement	108	113	95.5
branch	30	42	71.4
condition	13	21	61.9
subroutine	10	11	90.9
pod	3	3	100.0
total	164	190	86.3

package Lingua::ZH::MMSEG;
use strict;
use warnings;
use utf8;
use Encode qw (is_utf8);
use encoding 'utf8';
use List::Util qw(sum);

our $VERSION=0.4005;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(mmseg fmm word_freq);

=encoding utf8

=head1 NAME

Lingua::ZH::MMSEG Mandarin Chinese segmentation

=head1 SYNOPSIS

    #!/usr/bin/perl
    use utf8;
    use Lingua::ZH::MMSEG;

    my $zh_string="現代漢語的複合動詞可分三個結構語意關係來探討";

    my @phrases = mmseg($zh_string);
    # use MMSEG algorithm

    my @phrases = fmm($zh_string);
    # use Forward Maximum Matching algorithm

    while (<>) {
      chomp;
      push @phrases, mmseg;
    } # mmseg and fmm will parse $_ automaticly

    print $_, word_freq($_) for @phrases;
    # you can get phrase frequency by calling word_freq

=head1 DESCRIPTION

A problem in computational analysis of Chinese text is that there are no word
boundaries in conventionally printed text. Since the word is such a fundamental
linguistic unit, it is necessary to identify words in Chinese text so that
higher-level analyses can be performed.

Lingua::ZH::MMSEG implements L
original developed by L. The whole module is
rewritten in pure Perl, and the phrase library is
L<新酷音 forked from OpenFoundry|http://www.openfoundry.org/of/projects/436>.

=head1 INSTALL

To install this module, just type

    cpanm Lingua::ZH::MMSEG

If you don't have cpanm,

    curl -LO http://bit.ly/cpanm
    chmod +x cpanm
    sudo cp cpanm /usr/local/bin

=head1 FUNCTIONS

=head2 mmseg

    @phrases = mmseg($zh_string);
    @phrases = mmseg;
    # use $_ automatically

C convert a mandarin Chinese string to a sequence of phrases using
L algorithm. If there were any
english containted in the input string, it simply parse the linked ascii code as
one phrase. For example:

    $_ = "這裡有中文Today is Wednesday.這邊又有中文 I go to school on Friday.";
    print "$_\n" for mmseg;

    這裡有
    中文
    Today is Wednesday.
    這邊
    又有
    中文
     I go to school on Friday.

The ascii characters are recognized by C.

=head2 fmm (Forward Maximum Matching)

    @phrases = fmm($zh_string);
    @phrases = fmm;
    # use $_ automatically

C uses forward maximum matching (so called longest match principle) to
convert a mandarin Chinese string to a sequence of phrases. It uses the same
rule of C to deal with ascii string. The advantage of C is it has
lower complexity compare to C; the disadvantage is it cannot solve
ambiguity when there is multiple way to seperate a string.

=head2 word_freq

    $freq = word_freq($phrase);
    $freq = word_freq;
    # use $_ automatically

C return the phrase frequency defined in L<新酷音|http://www.openfoundry.org/of/projects/436>.

=head1 AUTHOR

Felix Ren-Chyan Chern (dryman) C<<  >>

=head1 LICENSE AND COPYRIGHT

L

=cut

our %dict;

while (){
  chomp;
  my ($phrase,$freq) = split;
  $dict{$phrase}=$freq;
}

sub word_freq {
  my $string = $_[0] ? $_[0] : $_;
  $dict{$string};
}

sub mmseg {
  my $string = $_[0] ? $_[0] : $_;
  my @phrases;
  die unless is_utf8($string);
  chomp ($string);
  for my $str (split (/([ -~]+)/, $string)) {
    if ($str =~ /^[ -~]/) {
      push @phrases, $str;
      next;
    }
    while($str){
      my $word1 = &_mmseg($str);
      push @phrases, $word1;
      $str = substr $str, length $word1;
    }
  }
  return @phrases;
}

sub fmm {
  my $string = $_[0] ? $_[0] : $_;
  my @phrases;
  die unless is_utf8($string);
  chomp ($string);
  for my $str (split (/([ -~])+/, $string)) {
    if ($str =~ /^[ -~]/) {
      push @phrases, $str,
      next;
    }
    while($str){
      for (reverse (1..(length $str))) {
        my $match = substr $str, 0, $_;
        if (defined $dict{$match} or $_==1){
          push @phrases, $match;
          $str = substr $str, $_;
          last;
        }
      }
    }
  }
  return @phrases;
}


sub _mmseg {
  my $str = shift;
  my @chunk = &_findChunk($str);

  return $chunk[0]->{w1} if $#chunk == 0;

  # rule 1, find max length chunks
  my @mlc_tmp = sort {$b->{len} <=> $a->{len}} @chunk;
  my @max_len_chunk = grep {$_->{len} == $mlc_tmp[0]->{len}} @mlc_tmp;
  return $max_len_chunk[0]->{w1} if $#max_len_chunk == 0;

  # rule 2, find max avg length chunks
  my @malc_tmp = sort {$b->{avglen} <=> $a->{avglen}} @max_len_chunk;
  my @max_avglen_chunk = grep {$_->{avglen} == $malc_tmp[0]->{avglen}} @malc_tmp;
  return $max_avglen_chunk[0]->{w1} if $#max_avglen_chunk == 0;

  # rule 3, smallest varience
  for (@max_len_chunk) {
    my $avg = $_->{avglen};
    my @word = ($_->{w1},$_->{w2},$_->{w3});
    pop @word unless $word[$#word];
    my @len = map {length $_} @word;
    my $varience = sqrt ((sum (map {$_**2-$avg**2} @len))/(scalar @len));
    $_->{varience} = $varience;
  }
  my @mvc_tmp = sort {$a->{varience} <=> $b->{varience}} @max_len_chunk;
  my @min_varience_chunk =
    grep {abs($_->{varience} - $mvc_tmp[0]->{varience})<0.01} @mvc_tmp;
  return $min_varience_chunk[0]->{w1} if $#min_varience_chunk == 0;
  # rule 4, check length one word and choose max freq of it
  for (@min_varience_chunk) {
    my $freq = 0;
    $freq += $dict{$_->{w1}} if length $_->{w1} == 1 and defined $dict{$_->{w1}};
    $freq += $dict{$_->{w2}} if length $_->{w2} == 1 and defined $dict{$_->{w2}};
    $freq += $dict{$_->{w3}} if length $_->{w3} == 1 and defined $dict{$_->{w3}};
    $_->{freq} = $freq;
  }
  my @last = sort {$b->{freq} <=> $a->{freq}} @min_varience_chunk;
  return $last[0]->{w1};
}




sub _findChunk{
  my $str = shift;
  my $index = 0;
  my @chunk;

  my @word1;
  # will fail if $str=""
  for (1..(length($str) - $index)){
    my $substr = substr $str, $index, $_;
    push @word1, $substr if defined $dict{$substr} or $_==1;
  }
  foreach my $w1 (@word1){
    my $l1 = length $w1;
    my $index = $index + $l1;
    my @word2;

    if (length($str) - $index == 0){
      push @chunk, {
        w1 => $w1,
        w2 => undef,
        w3 => undef,
        len => $l1,
        avglen => $l1,
      };
      next;
    }

    for (1..(length($str) - $index)){
      my $substr = substr $str, $index, $_;
      push @word2, $substr if defined $dict{$substr} or $_==1;
    }

    foreach my $w2 (@word2){
      my $l2 = length $w2;
      my $index = $index + $l2;

      if (length($str) - $index == 0){
        push @chunk, {
          w1 => $w1,
          w2 => $w2,
          w3 => undef,
          len => $l1+$l2,
          avglen => ($l1+$l2)/2,
        };
        next;
      }

      for (1..(length($str) - $index)){
        my $substr = substr $str, $index, $_;
        if (defined $dict{$substr} or $_==1){
          my $w3 = $substr;
          my $l3 = length $w3;
          push @chunk, {
            w1 => $w1,
            w2 => $w2,
            w3 => $w3,
            len => $l1+$l2+$l3,
            avglen => ($l1+$l2+$l3)/3,
          };
        }
      }
    }
  }
  return @chunk;
}

1;

__DATA__