CHISE.pm

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