CHISE.pm

   1 #
   2 # CHISE.pm by Shigeki Moro
   3 # $Id: CHISE.pm,v 1.5 2003-08-10 15:52:15 moro Exp $
   4 #
   5 package CHISE;
   6
   7 use strict;
   8 use warnings;
   9 use utf8;
  10 use BerkeleyDB;
  11 use overload;
  12
  13 sub import {
  14   overload::constant ( 'qr' => \&ChiseLikeRegex )
  15 }
  16
  17 sub unimport {
  18   overload::remove_constant
  19 }
  20
  21 our ($EXCLUSIVE, $HAVE_INTERSECTION, $PROPER_SUBSET, $PROPER_SUPERSET, $EQSET);
  22 ($EXCLUSIVE, $HAVE_INTERSECTION, $PROPER_SUBSET, $PROPER_SUPERSET, $EQSET)
  23   = (1, 2, 3, 4, 5);
  24
  25 # データベースの場�����を����������指�����。いずれはlibchiseに...
  26 # データベースの全ファイルをchownしないと�����えないかも
  27 my $DB_HOME='';
  28 if (-e '/usr/local/lib/chise/char-db') {
  29   $DB_HOME = '/usr/local/lib/chise/char-db';
  30 } elsif (-e '/sw/lib/xemacs-21.4.11/powerpc-apple-darwin6.6/char-db') {
  31   $DB_HOME = '/sw/lib/xemacs-21.4.11/powerpc-apple-darwin6.6/char-db';
  32 } elsif (-e '/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db') {
  33   $DB_HOME = '/usr/local/lib/xemacs-21.4.11/i686-pc-linux/char-db';
  34 } elsif (-e '/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db') {
  35   $DB_HOME = '/usr/local/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
  36 } elsif (-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db'){
  37   $DB_HOME = '/usr/local/xemacs-utf2000/lib/xemacs-21.4.11/powerpc-apple-darwin6.4/char-db';
  38 } elsif (-e '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db') {
  39   $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
  40 } elsif (-e '/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db') {
  41   $DB_HOME = '/usr/local/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
  42 } elsif (-e '/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db'){
  43   $DB_HOME = '/usr/local/xemacs-utf2000/lib/xemacs-21.4.10/powerpc-apple-darwin6.4/char-db';
  44 } elsif (-e 'd:/work/chise/char-db'){
  45   $DB_HOME = 'd:/work/chise/char-db';
  46 } else {
  47   print STDERR "CHISE.pm: No database found.\n";
  48   print STDERR "CHISE.pm: Please set \$DB_HOME to CHISE.pm.\n";
  49   exit 1;
  50 }
  51
  52 #my $cache_size = 1024 * 1024 * 64;
  53
  54 my %alias = ();
  55 my %alias_reverse = ();
  56 for (glob "$DB_HOME/system-char-id/*") {
  57   s/^.*\/([^\/]+)$/$1/;
  58   my $i = $_;
  59   s/^\->/to_/;    # Perlではリファレンスに
  60   s/^<\-/from_/;  # "-" などが�����えないため、����������しておく。
  61   s/^=>/mapto/;
  62   s/^=//;
  63   s/\-/_/g;
  64   $alias{$_} = $i;
  65   $alias_reverse{$i} = $_;
  66 }
  67 %alias = (
  68           %alias,
  69           'radical','ideographic-radical',
  70           'strokes','total-strokes',
  71 );
  72
  73 #--- exportする予�����の関数 -------------------------------------#
  74
  75 sub new (@) {
  76   # 既存の�����字オブジェクトの生成
  77   my $invocant = shift;
  78   my $class = ref($invocant) || $invocant;
  79   my $self  = { @_ };
  80   bless $self, $class;
  81   my $key = ($self->chars)[0]; # 要エラーチェック
  82   my($value, $result);
  83   for my $dbname (glob "$DB_HOME/system-char-id/*") {
  84     $value = &getvalue($dbname, $key);
  85     if ($value) {
  86       $dbname =~ s/^.*\/([^\/]+)$/$1/;
  87       $result->{$alias_reverse{$dbname}} = $value;
  88     }
  89   }
  90   return bless $result, $class;
  91 }
  92
  93 sub define_char {
  94   # �����しい�����字オブジェクトの生成
  95   my $invocant = shift;
  96   my $class = ref($invocant) || $invocant;
  97   my $self = {@_};
  98   my $result = ();
  99   for my $i (keys %$self) {
 100     $result->{$alias_reverse{$alias{$i}}} = $$self{$i};
 101   }
 102   return bless $result, $class;
 103 }
 104
 105 sub dumpAttr {
 106   # �����字オブジェクトが持っている全属性をprint
 107   my $self = shift;
 108   for my $i (keys %$self) {
 109     print "$i => $$self{$i}\n";
 110   }
 111 }
 112
 113 sub addAttr {
 114   # �����字オブジェクトに属性を追加
 115   my $model = shift;
 116   my $self = $model->define_char(%$model, @_);
 117   return $self;
 118 }
 119
 120 sub delAttr (@) {
 121   # �����字オブジェクトから属性を削除
 122   my $model = shift;
 123   delete $$model{$_} foreach (@_);
 124   my $self = $model->define_char(%$model);
 125   return $self;
 126 }
 127
 128 # 属性名で属性値を�����す
 129 # 例: $s->morohashi_daikanwa
 130 # cf. get_char_attribute
 131 for my $attrname (keys %alias) {
 132   my $slot = __PACKAGE__ . "::$attrname";
 133   no strict "refs";
 134   *$slot = sub {
 135     my $self = shift;
 136     my $dbname = exists $alias{$attrname}
 137       ? $alias_reverse{$alias{$attrname}}
 138       : $attrname;
 139     return $self->{$dbname};
 140   }
 141 }
 142 #for my $attrname (keys %alias) {
 143 #  my $slot = __PACKAGE__ . "::$attrname";
 144 #  no strict "refs";
 145 #  *$slot = sub {
 146 #    my $self = shift;
 147 #    my @result;
 148 #    for my $i ($self->chars) {
 149 #      my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
 150 #      push @result, $j if $j;
 151 #    }
 152 #    return @result;
 153 #  }
 154 #}
 155
 156 sub compare {
 157   # �����字オブジェクトどうしを比�����して、
 158   # �����合の重なり具合を�����す。
 159   my($a, $b) = @_;
 160   my($aonly, $bonly, $common) = (0, 0, 0);
 161   for my $i (&cup(keys %$a, keys %$b)) {
 162     if (exists $a->{$i} and exists $b->{$i}) {
 163       if ($a->{$i} eq $b->{$i}) {
 164         $common++;
 165       } else {
 166         $aonly++ if (exists $a->{$i});
 167         $bonly++ if (exists $b->{$i});
 168       }
 169     }
 170   }
 171   if ($common == 0) {
 172     return $EXCLUSIVE; # �����他
 173   } elsif ($aonly == 0 and $bonly == 0) {
 174     return $EQSET; # �����全一致
 175   } elsif ($aonly == 0) {
 176     return $PROPER_SUBSET; # $aは$bの��������������������合
 177   } elsif ($bonly == 0) {
 178     return $PROPER_SUPERSET; # $bは$aの��������������������合
 179   } else {
 180     return $HAVE_INTERSECTION;
 181   }
 182 }
 183
 184 sub rate_of_coincidence {
 185   # �����字オブジェクトどうしの属性の一致�����を出す。
 186   my($a, $b) = @_;
 187   my($all_attr, $common_attr) = (0, 0);
 188   for my $i (&cup(keys %$a, keys %$b)) {
 189     if ($a->{$i} eq $b->{$i}) {
 190       $all_attr++;
 191       $common_attr++;
 192     } else {
 193       $all_attr++ if (exists $a->{$i});
 194       $all_attr++ if (exists $b->{$i});
 195     }
 196   }
 197   return $all_attr ? ($common_attr / $all_attr) : 0;
 198 }
 199
 200 sub ph2char ($) {
 201   # �����体参照から?xを得る
 202   my $ph = shift;
 203   my %alias = (
 204                'C1','chinese-cns11643-1',
 205                'C2','chinese-cns11643-2',
 206                'C3','chinese-cns11643-3',
 207                'C4','chinese-cns11643-4',
 208                'C5','chinese-cns11643-5',
 209                'C6','chinese-cns11643-6',
 210                'C7','chinese-cns11643-7',
 211                'CB','ideograph-cbeta',
 212                'CDP','chinese-big5-cdp',
 213                'GT','ideograph-gt',
 214                'GT-K','ideograph-gt',
 215                'HZK1','ideograph-hanziku-1',
 216                'HZK2','ideograph-hanziku-2',
 217                'HZK3','ideograph-hanziku-3',
 218                'HZK4','ideograph-hanziku-4',
 219                'HZK5','ideograph-hanziku-5',
 220                'HZK6','ideograph-hanziku-6',
 221                'HZK7','ideograph-hanziku-7',
 222                'HZK8','ideograph-hanziku-8',
 223                'HZK9','ideograph-hanziku-9',
 224                'HZK10','ideograph-hanziku-10',
 225                'HZK11','ideograph-hanziku-11',
 226                'HZK12','ideograph-hanziku-12',
 227                'J78','japanese-jisx0208-1978',
 228                'J83','japanese-jisx0208',
 229                'J90','japanese-jisx0208-1990',
 230                'JSP','japanese-jisx0212',
 231                'JX1','japanese-jisx0213-1',
 232                'JX2','japanese-jisx0213-2',
 233                'K0','korean-ksc5601',
 234                'M','ideograph-daikanwa',
 235               );
 236   my $keys = join '|', sort keys %alias;
 237   my($phname, $phvalue) = ($ph =~ /^\&(?:I\-)?($keys)\-?([0-9a-f]+);$/i);
 238   if (exists $alias{$phname}) {
 239     if ($alias{$phname} =~ /daikanwa|gt/) {
 240       $phvalue =~ s/^0+//;
 241     } else {
 242       $phvalue = "0x$phvalue";
 243     }
 244     tie my %h, "BerkeleyDB::Hash",
 245       -Filename => "$DB_HOME/$alias{$phname}/system-char-id"
 246       or die "Cannot open file $alias{$phname}: $! $BerkeleyDB::Error\n";
 247     if (exists $h{$phvalue}) {
 248       return $h{$phvalue};
 249     } else {
 250       #print STDERR "\tCan't convert $phname - $phvalue (no value in db).\n";
 251       return $ph;
 252     }
 253     untie %h;
 254   } else {
 255     #print STDERR "\tCan't convert $phname - $phvalue.\n";
 256     return $ph;
 257   }
 258 }
 259
 260 #--- 正規表現のCHISE的拡張 ------------------------------------#
 261
 262 sub ChiseLikeRegex ($) {
 263   my ($RegexLiteral) = @_;
 264   #print STDERR "BEFORE: $RegexLiteral\n"; # for debug
 265   $RegexLiteral =~ s/\\same_strokes_(\d)/(??{CHISE->same_strokes(\$$1)})/g;
 266   #$RegexLiteral =~ s/\\same_strokes_(\d)/[川山三]/g;
 267   #print STDERR "AFTER:  $RegexLiteral\n"; # for debug
 268   return $RegexLiteral;
 269 }
 270
 271 sub same_strokes {
 272   my $self = shift;
 273   my $backtrace = shift;
 274   my $db = "$DB_HOME/system-char-id/total-strokes";
 275   my $temp = &getvalue($db, "?$backtrace");
 276   my $result = '';
 277   for my $i (&getkeys($db, $temp)) {
 278     $i =~ s/^\?//;
 279     $result .= $i;
 280   }
 281   #print STDERR $result, "\n";
 282   return "[$result]";
 283 }
 284
 285 #--- モジュール内のみで�����う予�����の関数 ----------------------#
 286
 287 sub chars {
 288   # ?... の配列を�����す
 289   my $self = shift;
 290   my @result = ('*');
 291   for my $attrname (keys %$self) {
 292     my @tmp = ();
 293     my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
 294     if (-f "$DB_HOME/$dbname/system-char-id") {
 295       @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $self->{$attrname}));
 296       @result = &cap(\@result, \@tmp);
 297     } elsif (-f "$DB_HOME/system-char-id/$dbname") {
 298       @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $self->{$attrname});
 299       @result = &cap(\@result, \@tmp);
 300     } else {
 301       die "cannot find $attrname: $! $BerkeleyDB::Error\n";
 302     }
 303   }
 304   return @result;
 305 }
 306
 307 sub utf8 {
 308   # UTF-8を�����す
 309   my $self = shift;
 310   my @result;
 311   for my $i ($self->chars) {
 312     $i =~ s/^\?//;
 313     # To Do: 私用�����域のは�����さないようにしないと。
 314     push @result, $i;
 315   }
 316   return @result;
 317 }
 318
 319 sub getvalue ($$) {
 320   # キーから値を�����り出す
 321   my($dbname, $key) = @_;
 322   my $value = '';
 323   my $db = new BerkeleyDB::Hash
 324   #tie my %h, "BerkeleyDB::Hash",
 325     -Filename => $dbname;
 326   #$value = $h{$key};
 327   #untie %h;
 328   $db->db_get($key, $value);
 329   undef $db;
 330   return $value;
 331 }
 332
 333 sub getkeys ($$) {
 334   # 値からキーの配列を�����り出す
 335   my($dbname, $value) = @_;
 336   my $db = new BerkeleyDB::Hash
 337   #tie my %h, "BerkeleyDB::Hash",
 338     -Filename => $dbname;
 339   my @keys = ();
 340   my ($k, $v) = ("", "") ;
 341   my $cursor = $db->db_cursor() ;
 342   #for my $k (keys %h) {
 343   while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
 344     push @keys, $k if ($v eq $value);
 345     #push @keys, $key if ($h{$key} eq $value);
 346   }
 347   undef $cursor ;
 348   undef $db ;
 349   #untie %h;
 350   return @keys;
 351 }
 352
 353 sub cap {
 354   # 2つの配列の積�����合を求める
 355   my($a, $b) = @_;
 356   if (!@$a or !@$b) {
 357     return ();
 358   } elsif ($$a[0] eq '*') { # '*'は全体�����合
 359     return @$b;
 360   } elsif ($$b[0] eq '*') {
 361     return @$a;
 362   } else {
 363     my %result = ();
 364     my @result = ();
 365     for my $i (@$a, @$b) {
 366       $result{$i}++;
 367       push @result, $i if ($result{$i} == 2);
 368     }
 369     return @result;
 370     #return grep {
 371     #  my $c = $_;
 372     #  grep /^$c$/, @$b;
 373     #} @$a;
 374   }
 375 }
 376
 377 sub cup {
 378   # 2つの配列の和�����合を求める
 379   my %result = ();
 380   for my $i (@_) { $result{$i}++; }
 381   return keys %result;
 382 }
 383
 384 #--------------------------------------------------------#
 385 1;