CHISE.pm

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