File Coverage

blib/lib/Lingua/ZH/WordSegment.pm

Criterion	Covered	Total	%
statement	28	126	22.2
branch	8	36	22.2
condition	0	6	0.0
subroutine	5	8	62.5
pod	0	5	0.0
total	41	181	22.6

package Lingua::ZH::WordSegment;

use 5.008007;
use strict;
use warnings;

require Exporter;
#use AutoLoader qw(AUTOLOAD);

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(seg seg_STDIO set_dic);
our $VERSION = '0.04';

my %wordFreqList=();				#Chinese word as key of the hash table, frequency is the value
my %longestWordListStart=();		#Chinese character as key in the hash table, length of the longest word starting with
								# this character is the value in the table

#reading the dictionary
sub set_dic {
	my ($dictFileName)=@_;
	%wordFreqList=();
	%longestWordListStart=();
	if (defined $dictFileName) {
		local *dictFile;
		open dictFile, $dictFileName or die "Can't open file $dictFileName.";
		load_dic(*dictFile);
		close dictFile;
	} else {
		load_dic(\*DATA);
	}
}

sub load_dic {
	my ($dictFile)=@_;
	while(<$dictFile>){
		s/\x0A//;s/\x0D//;s/\x20/\t/g;
		my $line=$_;
		my @entries=split(/\t/,$line);
		my ($thisChnWord,$thisFreq)=@entries;

		#print "$thisChnWord,$thisFreq\n"; #for debug
		$wordFreqList{$thisChnWord}=$thisFreq;

		if($thisChnWord=~/[\x00-\x7F]/){
		}else{
			my $headChar=$1 if ($thisChnWord=~/^([\x80-\xFF].)/);
			my $thisLen=length($thisChnWord)/2;		#the length of the Chinese word in character
			$longestWordListStart{$headChar}=0 if (! defined $longestWordListStart{$headChar});
			$longestWordListStart{$headChar}=$thisLen if($longestWordListStart{$headChar}<$thisLen);
		}
	}
}

sub seg_STDIO {
	while(){
		s/\x0A//g;s/\x0D//g;
		print seg($_); print "\n";
	}
}

sub seg {
	my ($thisSent)=@_;
	my $finalResult="";
	my $sentLen=length($thisSent);

	my $partialChnString="";
	my $index=0;
	while($index<$sentLen){
		my $thisChar=substr($thisSent, $index,1);

		if($thisChar ge "\x80")	{		#this is half of a Chinese character
			$thisChar=substr($thisSent,$index,2);
			$index+=2;
			$partialChnString=$partialChnString.$thisChar;
		}else{
			$index++;

			if($partialChnString ne ""){
				my $partialSegString=segmentZhStr($partialChnString);
				$finalResult=$finalResult.$partialSegString;

				$partialChnString="";
				$partialSegString="";
			}

			$finalResult=$finalResult.$thisChar;
		}
	}

	#in case of pure Chinese characters
	if($partialChnString ne ""){
		my $partialSegString=segmentZhStr($partialChnString);
		$finalResult=$finalResult.$partialSegString;

		$partialChnString="";
		$partialSegString="";
	}

	$finalResult=~s/^\x20+//;
	$finalResult=~s/\x20+\Z//;
	$finalResult=~s/\x20+/\x20/g;

	return $finalResult;
}

sub segmentZhStr{		#segmenting a string of Chinese characters, there should be no non-Chinese character in the string
	my $inputString=$_[0];
	my $result="";

	#for debug
	#print STDERR "Try to segment string $inputString\n";

	my $lenOfString=length($inputString)/2;
	my @arcTable=();

	#----------------------------------------------------------
	#step0, initialize the arcTable
	for(my $i=0;$i<$lenOfString;$i++){
		for(my $j=0;$j<$lenOfString;$j++){
			if($i==$j){
				$arcTable[$i][$j]=1;
			}else{
				$arcTable[$i][$j]=-1;
			}
		}
	}


	#-----------------------------------------------------------
	#step1: search for all possible arcs in the input string
	#		and create an array for them

	for(my $currentPos=0;$currentPos<$lenOfString;$currentPos++){		 #currentPos is the index of Chinese character
		my $currentChar=substr($inputString,$currentPos*2,2);

		#from this position, try to find all possible words led by this character
		my $possibleLen=$longestWordListStart{$currentChar};
		$possibleLen=1 if (! defined $possibleLen);
		#for debug
		#print STDERR "\n$currentChar=$possibleLen\n";

		if(($possibleLen+$currentPos)> ($lenOfString-1)){
			$possibleLen=$lenOfString-$currentPos;
		}

		while($possibleLen>=2){		#all possible words with more than 2 characters
			my $subString=substr($inputString,$currentPos*2,$possibleLen*2);

			#for debug
			#print STDERR "s=$subString\n";

			if($wordFreqList{$subString}){
				#for debug
				#print STDERR "$subString found\n";

				$arcTable[$currentPos][$currentPos+$possibleLen-1]=$wordFreqList{$subString};
			}


			$possibleLen--;
		}

	}

	#for debug
	#for($i=0;$i<$lenOfString;$i++){
	#	for($j=0;$j<$lenOfString;$j++){
	#		print "  ",$arcTable[$i][$j];
	#	}
	#	print "\n";
	#}


	#--------------------------------------------------------------------------
	#step2: from the arc table, try to find the best path as segmentation at
	#each point use the longest possible arc
	# Try from two directions for the search: left to right and right to left
	# using the one with higher product of frequency of the arcs

	my @leftRightSegLabel=();
	my @rightLeftSegLabel=();

	#initialize the segmentation label array
	for(my $k=0;$k<$lenOfString;$k++){
		$leftRightSegLabel[$k]=0;
		$rightLeftSegLabel[$k]=0;
	}

	#from left to right
	#-------------------------------
	my $leftToRightFreq=0;
	my $thisCharIndex=0;
	my $charIndexEnd=$lenOfString-1;

	while($thisCharIndex<$lenOfString){
		my $endCharIndex=$charIndexEnd;
		my $found=0;

		while((!$found)&&($endCharIndex>=$thisCharIndex)){
			if($arcTable[$thisCharIndex][$endCharIndex]!=-1){
				$leftToRightFreq+=log($arcTable[$thisCharIndex][$endCharIndex]);
				$found=1;
			}
			else{
				$endCharIndex--;
			}
		}

		$leftRightSegLabel[$endCharIndex]=1;
		$thisCharIndex=$endCharIndex+1;
	}

	#for debug
	#print STDERR @leftRightSegLabel,"\n $leftToRightFreq\n";

	#from right to left
	#---------------------------------
	my $rightToLeftFreq=0;
	$thisCharIndex=$lenOfString-1;

	while($thisCharIndex>=0){
		my $startCharIndex=0;
		my $found=0;
		while((!$found)&&($startCharIndex<=$thisCharIndex)){
			if($arcTable[$startCharIndex][$thisCharIndex]!=-1){
				$found=1;
				$rightToLeftFreq+=log($arcTable[$startCharIndex][$thisCharIndex]);
			}
			else{
				$startCharIndex++;
			}
		}

		$rightLeftSegLabel[$startCharIndex]=1;
		$thisCharIndex=$startCharIndex-1;
	}

	#for debug
	#print STDERR @rightLeftSegLabel,"\n $rightToLeftFreq\n";


	#---------------------------------------------------------------------------------
	# Step3: create result
	if($leftToRightFreq>$rightToLeftFreq){#using left to right solution, prefer right to left
		for(my $p=0;$p<$lenOfString;$p++){
			$result=$result.substr($inputString, $p*2, 2);

			if($leftRightSegLabel[$p]==1){
				$result=$result." ";
			}
		}
	}
	else{
		for(my $p=0;$p<$lenOfString;$p++){
			if($rightLeftSegLabel[$p]==1){
				$result=$result." ";
			}
			$result=$result.substr($inputString, $p*2, 2);
		}
	}

	$result=~s/^\x20+//;
	$result=~s/\x20+\Z//;

	#for debug
	#print "result=$result\n";

	return " $result ";
}

set_dic();
1;

=pod

=head1 NAME

Lingua::ZH::WordSegment - Simple Simplified Chinese Word Segmentation

=head1 SYNOPSIS

	use Lingua::ZH::WordSegment;
	print seg($str_in);
	seg_STDIO();# Read from STDIN, and print the segmented result to STDOUT

	set_dic($dictionary_file_name); #load word from the file, this is not a must
	perl -MLingua::ZH::WordSegment -e 'seg_STDIO();' < input_file > output_file

=head1 DESCRIPTION

The default word list is extracted from People's Daily in Jan, 1998 owned by Institute of Computational Linguistics, Peking University, China

This code is mainly written by Joy, [e-mail] in July 4th, 2001.

This program is a perl version of left-right mandarin segmentor
As LDC segmenter takes a long time to build the DB files which makes the
the training process last too long time.

For ablation experiments, we do not need to create the DB files because the
specific frequency dictionary will be used only once for each slice.

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 above is Joy's original declarations.



=head1 METHODS

	seg($str_in);	# return the string of segmentation result.
	seg_STDIO();	# Read from STDIN, and print the segmented result to STDOUT

	set_dic($dictionary_file_name)
	#The format of the dictionary file for each line is:
	# "chineseWord\tFrequency\n"
	#
	#Notice that if you don't call set_dic,
	#the default dictionary in GBK encoding will be loaded.
	#The default dictionary is extracted from corpus of the People's Daily,
	#January, 1998.
	#Thanks to Institute of Computational Linguistics, Peking University,China.

=head1 SEE ALSO


=head1 AUTHORS

Rewrited by Chen Yirong E [e-mail] E, September 21, 2006 and modified in Feb 20, 2007.
Original Author:
	Joy, [e-mail] in July 4th, 2001

=head1 KUDOS

Many thanks to Joy who made the code available.
Thanks to the PKU Corpus (from Institute of Computational Linguistics, Peking University, China) to help to automatic generate the default dictionary.

=head1 COPYRIGHT

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

See L

=cut

__DATA__