File Coverage

blib/lib/Lingua/ZH/WordSegmenter.pm

Criterion	Covered	Total	%
statement	12	159	7.5
branch	0	56	0.0
condition	0	11	0.0
subroutine	4	10	40.0
pod	2	2	100.0
total	18	238	7.5

package Lingua::ZH::WordSegmenter;

use warnings;
use strict;
use Encode;

# Constructor new
sub new {
    my $proto  = shift;
    my $class  = ref($proto) || $proto;

    my $self = {};
    bless($self, $class);

    # Run initialisation code
    return $self->_init(@_);
}

sub _init{
    my $self = shift;

    $self->{dic_encoding} = 'gbk';
    $self->{seperator} = ' ';
    $self->{verbose}=0;

    if (@_ != 0) { # We are expecting our configuration to come as an anonymous hash
        if (ref $_[0] eq 'HASH') {
            my $hash=$_[0];
            foreach my $key (keys %$hash) {
                $self->{lc($key)}=$hash->{$key};
            }
        }else { # Using a more conventional named args
            my %args = @_;
            foreach my $key (keys %args) {
                $self->{lc($key)}=$args{$key};
            }
        }
    }

    if($self->{dic}){
	my $FH;
	open $FH,$self->{dic} or die "Cant open file $self->{dic}, $!\n";
	$self->_load_dic($FH);
	close $FH;
    }else{
	$self->_load_dic(\*DATA);
    }

    return $self;
}

sub _dump_dic{
    my $self = shift;
    print "$_:$self->{headchar_maxlen}->{$_}:$self->{headchar_str}->{$_}\n" foreach keys %{$self->{headchar_maxlen}};
    print "$_:$self->{word_freq}->{$_}\n" foreach keys %{$self->{word_freq}};
}

sub _load_dic{
    my $self = shift;
    my $FH=shift;


    $self->{word_freq}={};
    $self->{headchar_maxlen}={};

    if($self->{verbose}){
	print "loading dic ...\n";
    }

    while(my $line = <$FH>){
	chomp $line;
	$line = decode($self->{dic_encoding},$line);

	my ($word,$freq) = split(/\s+/,$line);
	my $len=length($word);
	$self->{word_freq}->{$word}=$freq;

	if($word =~ m!^(\p{Han})!){
	    my $headchar=$1;
	    if (not exists $self->{headchar_maxlen}->{$headchar}){
		$self->{headchar_maxlen}->{$headchar} = $len;
		$self->{headchar_str}->{$headchar} = $word;
	    }else{
		if ($self->{headchar_maxlen}->{$headchar} < $len){
		    $self->{headchar_maxlen}->{$headchar} = $len;
		    $self->{headchar_str}->{$headchar} = $word;
		}
	    }
	}
    }

}

sub seg {
    my $self = shift;
    my $text = shift;
    my $encoding = shift;

    $encoding ||= 'gbk';
    $text = decode($encoding,$text);

    my $result="";

    while($text){
	if($text =~ s!^(\p{Han}+)!!){
	    my $han_str = $1;
	    $result .= $self->_seg_zh($han_str).$self->{seperator};
	}else{
	    $text =~ s!^([^\p{Han}]+)!!;
	    my $str = $1;
	    $str =~ s!\s+!$self->{seperator}!g;
	    $result .= $str.$self->{seperator};
	}
    }
    return $result;
}

sub _seg_zh{
    my $self = shift;
    my $input = shift;
    my $result="";

    if($self->{verbose}){
	print "Try to segment string $input\n";
    }

    my $len=length($input);
    my @arctable=();


    if($self->{verbose}){
	print "step0, initialize the arctable\n";
    }

    for(my $i=0;$i<$len;$i++){
	for(my $j=0;$j<$len;$j++){
	    if($i==$j){
		$arctable[$i][$j]=1;
	    }else{
		$arctable[$i][$j]=-1;
	    }
	}
    }


    if($self->{verbose}){
	print "step1: search for all possible arcs in the input string\n";
    }

    my @chars = split('',$input);

    for(my $i=0;$i<$len;$i++){

	#from this position, try to find all possible words led by this character
	my $possiblelen=$self->{headchar_maxlen}->{$chars[$i]};
	$possiblelen=1 if (not defined $possiblelen);

	if($self->{verbose}){
	    print "\n$chars[$i]=$possiblelen\n";
	}

	if(($possiblelen+$i) > ($len-1)){
	    $possiblelen=$len-$i;
	}

	#all possible words with more than 2 characters
	while($possiblelen>=2){
	    my $substr = substr($input,$i,$possiblelen);

	    if($self->{verbose}){
		print "s=$substr,len=$possiblelen\n";
	    }

	    if($self->{word_freq}->{$substr}){
		if($self->{verbose}){
		    print "$substr found\n";
		}

		$arctable[$i][$i+$possiblelen-1]=$self->{word_freq}->{$substr};
	    }
	    $possiblelen--;
	}
    }

    if($self->{verbose}){
	for(my $i=0;$i<$len;$i++){
	    for(my $j=0;$j<$len;$j++){
    		print "  ",$arctable[$i][$j];
	    }
	    print "\n";
	}
    }

    if($self->{verbose}){
	print "step2: from the arc table, try to find the best path as segmentation\n";
    }


    my @lrlabel=();
    my @rllabel=();

    for(my $k=0;$k<$len;$k++){
	$lrlabel[$k]=0;
	$rllabel[$k]=0;
    }

    my $lrfreq=0;
    my $index=0;

    while($index<$len){
	my $endindex=$len-1;
	my $found=0;

	while((!$found)&&($endindex>=$index)){
	    if($arctable[$index][$endindex]!=-1){
		$lrfreq+=log($arctable[$index][$endindex]);
		$found=1;
	    }
	    else{
		$endindex--;
	    }
	}

	$lrlabel[$endindex]=1;
	$index=$endindex+1;
    }

    my $rlfreq=0;
    $index=$len-1;

    while($index>=0){
	my $startindex=0;
	my $found=0;
	while((!$found)&&($startindex<=$index)){
	    if($arctable[$startindex][$index]!=-1){
		$found=1;
		$rlfreq+=log($arctable[$startindex][$index]);
	    }
	    else{
		$startindex++;
	    }
	}

	$rllabel[$startindex]=1;
	$index=$startindex-1;
    }

    if($self->{verbose}){
	print "Step3: create result\n";
    }

    if($lrfreq>$rlfreq){
	for(my $p=0;$p<$len;$p++){
	    $result .= $chars[$p];

	    if($lrlabel[$p]==1){
		$result .= $self->{seperator};
	    }
	}
    }else{
	for(my $p=0;$p<$len;$p++){
	    if($rllabel[$p]==1){
		$result .= $self->{seperator};
	    }
	    $result .= $chars[$p];
	}
    }

    if($self->{verbose}){
	print "result=$result\n";
    }

    return $result;
}



=head1 NAME

Lingua::ZH::WordSegmenter - Simplified Chinese Word Segmentation

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

    use Lingua::ZH::WordSegmenter;

    my $segmenter = Lingua::ZH::WordSegmenter->new();
    print encode('gbk', $segmenter->seg($_) );

=head1 Description

This is a perl version of simplified Chinese word segmentation.

The algorithm for this segmenter is to search the longest word at each
point from both left and right directions, and choose the one with
higher frequency product.

The original program is from the CPAN module Lingua::ZH::WordSegment
(http://search.cpan.org/~chenyr/) I did the follwing changes: 1) make
the interface object oriented; 2) make the internal string into utf8;
3) using sogou's dictionary (http://www.sogou.com/labs/dl/w.html) as
the default dictionary.


=head1 METHODS

=over 4

=item $segmenter = Lingua::ZH::WordSegmenter->new(%opinions)

This method constructs a new C object and
returns it.  Key/value pair arguments may be provided to set up the
initial state.  The following options correspond to attribute methods
described below:

   KEY            PURPOSE                       DEFAULT
   -----------    -------------                 --------------------
   dic            filename of the dic           sogou dic
   dic_encoding   encoding of the dic           "gbk"
   seperator      string to seperate wrods      " "
   verbose        show the segment process      0

=item $segmenter->seg($input,[$encoding])

Segment a input string, you can specify the encoding by the optional
parameter.

The return result is encoded in utf8 format.

=back

=head1 SEE ALSO

L

=head1 AUTHOR

Zhang Jun, C<<  >>

=head1 COPYRIGHT & LICENSE

Copyright 2007 Zhang Jun, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Lingua::ZH::WordSegmenter

__DATA__