eGuideDog::Dict::Mandarin - an informal Pinyin dictionary.

  use utf8;
  use eGuideDog::Dict::Mandarin;

  binmode(stdout, 'utf8');
  my $dict = eGuideDog::Dict::Mandarin->new();
  my @symbols = $dict->get_multi_phon("长");
  print "长(all pronunciation)：@symbols\n"; # zhang3 chang2
  my $symbol = $dict->get_pinyin("长");
  print "长(default pronunciation): $symbol\n"; # zhang3
  $symbol = $dict->get_pinyin("长江");
  print "长江的长: $symbol\n"; # chang2
  my @symbols = $dict->get_pinyin("拼音");
  print "拼音: @symbols\n"; # pin1 yin1
  my @words = $dict->get_words("长");
  print "Some words begin with 长: @words\n";

package eGuideDog::Dict::Mandarin;

use strict;
use warnings;
use utf8;
use Encode::CNMap;
use Storable;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use eGuideDog::Dict::Mandarin ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);

our $VERSION = '0.5';


# Preloaded methods go here.

sub new() {
  my $self = {};
  $self->{pinyin} = {}; # The most probably phonetic symbol
  $self->{chars} = {}; # all phonetic symbols (array ref)
  $self->{words} = {}; # word phonetic symbols (array ref)
  $self->{word_index} = {}; # the first char to words (array ref)
  $self->{char_rate} = {};
  bless $self, __PACKAGE__;

  # load dictionary file.
  my $dir = __FILE__;
  $dir =~ s/[.]pm$//;

  if(-e "$dir/Mandarin.dict") {
    my $dict = retrieve("$dir/Mandarin.dict");
    $self->{pinyin} = $dict->{pinyin};
    $self->{chars} = $dict->{chars};
    $self->{words} = $dict->{words};
    $self->{word_index} = $dict->{word_index};
    $self->{char_rate} = $dict->{char_rate};
    $self->{symbol_size} = $dict->{symbol_size};
  }

  return $self;
}

sub update_symbol_size {
  my ($self) = @_;
  my $all = "a ai an ang ao ba bai ban bang bao bei ben beng bi bian biao bie bin bing bo bu ca cai can cang cao ce cen ceng cha chai chan chang chao che chen cheng chi chong chou chu chua chuai chuan chuang chui chun chuo ci cong cou cu cuan cui cun cuo da dai dan dang dao de dei den deng di dia dian diao die ding diu dong dou du duan dui dun duo e ei en eng er fa fan fang fei fen feng fo fou fu ga gai gan gang gao ge gei gen geng gong gou gu gua guai guan guang gui gun guo ha hai han hang hao he hei hen heng hong hou hu hua huai huan huang hui hun huo ji jia jian jiang jiao jie jin jing jiong jiu ju juan jue jun ka kai kan kang kao ke kei ken keng kong kou ku kua kuai kuan kuang kui kun kuo la lai lan lang lao le lei leng li lia lian liang liao lie lin ling liu lo long lou lu lu: luan lu:e lun luo ma mai man mang mao me mei men meng mi mian miao mie min ming miu mo mou mu na nai nan nang nao ne nei nen neng ng ni nia nian niang niao nie nin ning niu nong nou nu nu: nuan nu:e nuo o ou pa pai pan pang pao pei pen peng pi pian piao pie pin ping po pou pu qi qia qian qiang qiao qie qin qing qiong qiu qu quan que qun ran rang rao re ren reng ri rong rou ru rua ruan rui run ruo sa sai san sang sao se sen seng sha shai shan shang shao she shei shen sheng shi shou shu shua shuai shuan shuang shui shun shuo si song sou su suan sui sun suo ta tai tan tang tao te teng ti tian tiao tie ting tong tou tu tuan tui tun tuo wa wai wan wang wei wen weng wo wu xi xia xian xiang xiao xie xin xing xiong xiu xu xuan xue xun ya yan yang yao ye yi yin ying yo yong you yu yuan yue yun za zai zan zang zao ze zei zen zeng zha zhai zhan zhang zhao zhe zhei zhen zheng zhi zhong zhou zhu zhua zhuai zhuan zhuang zhui zhun zhuo zi zong zou zu zuan zui zun zuo";
  $all =~ s/u:/v/g;
  my @all_pinyin = split(' ', $all);

  foreach my $py (@all_pinyin) {
    for (1 .. 5) {
      my $pytone = $py . $_;
      system("espeak -vzh \"$pytone\" -w /tmp/espeak_size.1");
      system("espeak -vzh \"$pytone$pytone\" -w /tmp/espeak_size.2");
      my $size = (-s '/tmp/espeak_size.2') - (-s '/tmp/espeak_size.1');
      $self->{symbol_size}->{$pytone} = $size;
    }
  }
}

sub import_symbol_size {
  my ($self, $file) = @_;
  open(SYMBOL_SIZE, '<', $file);
  while (<SYMBOL_SIZE>) {
    my @pair = split(/\s/, $_);
    $self->{symbol_size}->{$pair[0]} = $pair[1];
  }
  close(SYMBOL_SIZE);
}

sub get_symbol_size {
  my ($self, $symbol) = @_;
  if ($self->{symbol_size}->{$symbol}) {
    return $self->{symbol_size}->{$symbol};
  } else {
    warn "$symbol size not exist";
    return undef;
  }
}

sub print_symbol_size_list {
  my ($self) = @_;
  foreach (sort(keys %{$self->{symbol_size}})) {
    print $_, "\t", $self->{symbol_size}->{$_}, "\n";
  }
}

sub update_dict {
  my $self = shift;

  $self->{pinyin} = {};
  $self->{chars} = {};
  $self->{words} = {};
  $self->{word_index} = {};
  $self->{char_rate} = {};

  $self->import_unihan("HanyuPinlu.txt");
  # if a character is not exist in HanyuPinlu, it will look up in Mandarin.txt. 
  $self->import_unihan("Mandarin.txt");
  $self->import_zh_list("zh_list");
  $self->import_zh_list("zh_listx");
  $self->import_char_rate("HanyuPinlu.txt");
  $self->import_symbol_size("symbol_size_list");

  my $dict = {pinyin => $self->{pinyin},
	      chars => $self->{chars},
	      words => $self->{words},
	      word_index => $self->{word_index},
        char_rate => $self->{char_rate},
        symbol_size => $self->{symbol_size},
	     };
  store($dict, "Mandarin.dict");
}

sub import_char_rate {
  my ($self, $file) = @_;
  open(DATA_FILE, '<', $file);
  while(my $line = <DATA_FILE>) {
    chomp($line);
    my @items = split(/\s+/, $line);
    my $rate = 0;
    foreach (@items[1 .. $#items]) {
      /\((.*)\)/;
      $rate += $1;
    }
    my $char = chr(hex($items[0]));
    $self->{char_rate}->{$char} = $rate;
#    my $char_simp = utf8_to_simputf8($char);
#    if ($char_simp !~ /[?]/) {
#      $self->{char_rate}->{$char_simp} = $rate;
#    }
#    my $char_trad = utf8_to_tradutf8($char);
#    if ($char_trad !~ /[?]/) {
#      $self->{char_rate}->{$char_trad} = $rate;
#    }
  }
  close(DATA_FILE);
}

sub import_unihan {
  my ($self, $file) = @_;
  open(DATA_FILE, '<', $file);
  while(my $line = <DATA_FILE>) {
    chomp($line);
    $line = lc($line); # specific to Mandarin.txt
    my @items = split(/\s+/, $line);
    s/\(.*\)// foreach (@items); # specific to HanyuPinlu
    my $char = chr(hex($items[0]));
    my @phons = @items[1 .. $#items];
    if (not defined $self->{chars}->{$char}) {
      $self->{chars}->{$char} = \@phons;
    }
    my $char_simp = utf8_to_simputf8($char);
    if ($char_simp !~ /[?]/) {
      if (!defined $self->{chars}->{$char_simp}) {
        $self->{chars}->{$char_simp} = \@phons;
      }
    }
    my $char_trad = utf8_to_tradutf8($char);
    if ($char_trad !~ /[?]/) {
      if (!defined $self->{chars}->{$char_trad}) {
        $self->{chars}->{$char_trad} = \@phons;
      }
    }
  }
  close(DATA_FILE);
}

sub add_symbol {
  my ($self, $char, $symbol) = @_;

  if (not $self->{chars}->{$char}) {
    $self->{chars}->{$char} = [$symbol];
    return 1;
  } else {
    foreach (@{$self->{chars}->{$char}}) {
      if ($symbol eq $_) {
	return 0;
      }
    }
    $self->{chars}->{$char} = [@{$self->{chars}->{$char}}, $symbol];
    return 1;
  }
}

sub import_zh_list {
    my ($self, $zh_list) = @_;

    open(ZH_LIST, '<:utf8', $zh_list);
    while (my $line = <ZH_LIST>) {
        if ($line =~ /^(.)\s([^\s]*)\s$/) {
            if ($1 && $2) {
                my $ch = $1;
                my $py = $2;
                if ($py =~ /^[a-z]*[1-5]$/) {
                    $self->{pinyin}->{$ch} = $py;
                    $self->add_symbol($ch, $py);
                }
            }
        } elsif ($line =~ /^[(]([^)]*)[)]\s([^\s]*)\s$/) {
            my @chars = split(/ /, $1);
            my $phon = $2;
            my @symbols;
            if ($phon =~ /[|]/) {
                @symbols = split(/[|]/, $phon);
            } else {
                while($phon && $phon =~ /^([a-z]*[0-9])(.*)/) {
                    push(@symbols, $1);
                    $phon = $2;
                }
            }
            if ($#chars != $#symbols) {
                warn "Dictionary error:" . "@chars" . "-" . "@symbols";
                next;
            }
            my $word = join("", @chars);
            if ($self->{word_index}->{$chars[0]}) {
                push(@{$self->{word_index}->{$chars[0]}}, $word);
            } else {
                $self->{word_index}->{$chars[0]} = [$word];
            }
            $self->{words}->{$word} = \@symbols;
            for (my $i = 0; $i <= $#chars; $i++) {
                $self->add_symbol($chars[$i], $symbols[$i]);
            }
        }
    }
    close(ZH_LIST);
}

sub get_pinyin {
    my ($self, $str) = @_;

    if (not utf8::is_utf8($str)) {
        if (not utf8::decode($str)) {
            warn "$str is not in utf8 encoding.";
            return undef;
        }
    } elsif (not $str) {
        return undef;
    }

    if (wantarray) {
        my @pinyin;
        for (my $i = 0; $i < length($str); $i++) {
            my $char = substr($str, $i, 1);
            my @words = $self->get_words($char);
            my $longest_word = '';
            foreach my $word (@words) {
                if (index($str, $word) == 0) {
                    if (length($word) > length($longest_word)) {
                        $longest_word = $word;
                    }
                }
            }
            if ($longest_word) {
                push(@pinyin, @{$self->{words}->{$longest_word}});
                $i += $#{$self->{words}->{$longest_word}};
            } else {
                push(@pinyin, $self->{pinyin}->{$char});
            }
        }
        return @pinyin;
    } else {
        my $char = substr($str, 0, 1);
        my @words = $self->get_words($char);
        my $longest_word = '';
        foreach my $word (@words) {
            if (index($str, $word) == 0) {
                if (length($word) > length($longest_word)) {
                    $longest_word = $word;
                }
            }
        }
        if ($longest_word) {
            return $self->{words}->{$longest_word}->[0];
        } else {
            return $self->{pinyin}->{$char};
        }
    }
}

sub get_words {
  my ($self, $char) = @_;

  if ($self->{word_index}->{$char}) {
    return @{$self->{word_index}->{$char}};
  } else {
    return ();
  }
}

sub is_multi_phon {
  my ($self, $char) = @_;
  return $#{$self->{chars}->{$char}};
}

sub get_multi_phon {
  my ($self, $char) = @_;
  if ($self->{chars}->{$char}) {
    return @{$self->{chars}->{$char}};
  } else {
    return undef;
  }
}

sub print_phon_char_list {
  my ($self, $char) = @_;
  my $all = "a ai an ang ao ba bai ban bang bao bei ben beng bi bian biao bie bin bing bo bu ca cai can cang cao ce cen ceng cha chai chan chang chao che chen cheng chi chong chou chu chua chuai chuan chuang chui chun chuo ci cong cou cu cuan cui cun cuo da dai dan dang dao de dei den deng di dia dian diao die ding diu dong dou du duan dui dun duo e ei en eng er fa fan fang fei fen feng fo fou fu ga gai gan gang gao ge gei gen geng gong gou gu gua guai guan guang gui gun guo ha hai han hang hao he hei hen heng hong hou hu hua huai huan huang hui hun huo ji jia jian jiang jiao jie jin jing jiong jiu ju juan jue jun ka kai kan kang kao ke kei ken keng kong kou ku kua kuai kuan kuang kui kun kuo la lai lan lang lao le lei leng li lia lian liang liao lie lin ling liu lo long lou lu lu: luan lu:e lun luo ma mai man mang mao me mei men meng mi mian miao mie min ming miu mo mou mu na nai nan nang nao ne nei nen neng ng ni nia nian niang niao nie nin ning niu nong nou nu nu: nuan nu:e nuo o ou pa pai pan pang pao pei pen peng pi pian piao pie pin ping po pou pu qi qia qian qiang qiao qie qin qing qiong qiu qu quan que qun ran rang rao re ren reng ri rong rou ru rua ruan rui run ruo sa sai san sang sao se sen seng sha shai shan shang shao she shei shen sheng shi shou shu shua shuai shuan shuang shui shun shuo si song sou su suan sui sun suo ta tai tan tang tao te teng ti tian tiao tie ting tong tou tu tuan tui tun tuo wa wai wan wang wei wen weng wo wu xi xia xian xiang xiao xie xin xing xiong xiu xu xuan xue xun ya yan yang yao ye yi yin ying yo yong you yu yuan yue yun za zai zan zang zao ze zei zen zeng zha zhai zhan zhang zhao zhe zhei zhen zheng zhi zhong zhou zhu zhua zhuai zhuan zhuang zhui zhun zhuo zi zong zou zu zuan zui zun zuo";
  $all =~ s/u:/v/g;
  my @all_pinyin = split(' ', $all);

  my %phonh;
  foreach my $char (keys %{$self->{chars}}) {
    my $phons = $self->{chars}->{$char};
    foreach my $phon (@{$phons}) {
      if ($phonh{$phon}) {
        push(@{$phonh{$phon}}, $char);
      } else {
        my @p = ($char);
        $phonh{$phon} = \@p;
      }
    }
  }
  foreach my $py (@all_pinyin) {
    for (1 .. 5) {
      my $pytone = $py . $_;
      if ($phonh{$pytone}) {
        my @p1 = @{$phonh{$pytone}};
        my @p2 = sort {($self->{char_rate}->{$b} || 0) <=> ($self->{char_rate}->{$a} || 0)} @p1;
        print "$pytone: @p2\n";
#        foreach (@p2) {
#          print $_, "(", $self->{char_rate}->{$_} || 0, ") ";
#        }
#        print "\n";
      } else {
        print "$pytone:\n";
      }
    }
  }
}

1;
__END__
# Below is stub documentation for your module. You'd better edit it!