CHISE.pm

   1 #
   2 # CHISE.pm by Shigeki Moro
   3 # $Id: CHISE.pm,v 1.1 2003-02-02 12:25:10 moro Exp $
   4 #
   5 package CHISE;
   6
   7 use strict;
   8 use BerkeleyDB;
   9
  10 my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';
  11
  12 my %alias = ();
  13 my %alias_reverse = ();
  14 for (glob "$DB_HOME/system-char-id/*") {
  15   s/^.*\/([^\/]+)$/$1/;
  16   my $i = $_;
  17   s/\->/to_/;
  18   s/<\-/from_/;
  19   s/=>/map_/;
  20   s/\-/_/g;
  21   $alias{$_} = $i;
  22   $alias_reverse{$i} = $_;
  23 }
  24 %alias = (
  25           %alias,
  26           'radical','ideographic-radical',
  27           'strokes','total-strokes',
  28 );
  29
  30 #--------------------------------------------------------#
  31
  32 sub new {
  33   # 既存の�����字オブジェクトの生成
  34   my $invocant = shift;
  35   my $class = ref($invocant) || $invocant;
  36   my $self  = { @_ };
  37   bless $self, $class;
  38   my $key = ($self->chars)[0]; # 要エラーチェック
  39   my($value, $result);
  40   for my $dbname (glob "$DB_HOME/system-char-id/*") {
  41     $value = &getvalue($dbname, $key);
  42     if ($value) {
  43       $dbname =~ s/^.*\/([^\/]+)$/$1/;
  44       $result->{$alias_reverse{$dbname}} = $value;
  45     }
  46   }
  47   return bless $result, $class;
  48 }
  49
  50 sub define_char {
  51   # �����しい�����字オブジェクトの生成
  52   my $invocant = shift;
  53   my $class = ref($invocant) || $invocant;
  54   my $self = {@_};
  55   my $result = ();
  56   for my $i (keys %$self) {
  57     $result->{$alias_reverse{$alias{$i}}} = $$self{$i};
  58   }
  59   return bless $result, $class;
  60 }
  61
  62 sub dumpAttr {
  63   # �����字オブジェクトが持っている全属性を表示
  64   my $self = shift;
  65   for my $i (keys %$self) {
  66     print "$i => $$self{$i}\n";
  67   }
  68 }
  69
  70 sub addAttr {
  71   # �����字オブジェクトに属性を追加
  72   my $model = shift;
  73   my $self = $model->define_char(%$model, @_);
  74   return $self;
  75 }
  76
  77 sub delAttr (@) {
  78   # �����字オブジェクトから属性を削除
  79   my $model = shift;
  80   delete $$model{$_} foreach (@_);
  81   my $self = $model->define_char(%$model);
  82   return $self;
  83 }
  84
  85 # 属性名で属性値を�����す
  86 # 例: $s->morohashi_daikanwa
  87 for my $attrname (keys %alias) {
  88   my $slot = __PACKAGE__ . "::$attrname";
  89   no strict "refs";
  90   *$slot = sub {
  91     my $self = shift;
  92     my $dbname = exists $alias{$attrname}
  93       ? $alias_reverse{$alias{$attrname}}
  94       : $attrname;
  95     return $self->{$dbname};
  96   }
  97 }
  98 #for my $attrname (keys %alias) {
  99 #  my $slot = __PACKAGE__ . "::$attrname";
 100 #  no strict "refs";
 101 #  *$slot = sub {
 102 #    my $self = shift;
 103 #    my @result;
 104 #    for my $i ($self->chars) {
 105 #      my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
 106 #      push @result, $j if $j;
 107 #    }
 108 #    return @result;
 109 #  }
 110 #}
 111
 112 sub utf8 {
 113   # UTF-8を�����す
 114   my $self = shift;
 115   my @result;
 116   for my $i ($self->chars) {
 117     $i =~ s/^\?//;
 118     # To Do: 私用�����域のは�����さないようにしないと。
 119     push @result, $i;
 120   }
 121   return @result;
 122 }
 123
 124 sub compare {
 125   my($a, $b) = @_;
 126   my($all_attr, $common_attr) = (0, 0);
 127   for my $i (&cup(keys %$a, keys %$b)) {
 128     if ($a->{$i} eq $b->{$i}) {
 129       $all_attr++;
 130       $common_attr++;
 131     } else {
 132       $all_attr++ if (exists $a->{$i});
 133       $all_attr++ if (exists $b->{$i});
 134     }
 135   }
 136   return $all_attr ? ($common_attr / $all_attr) : 0;
 137 }
 138
 139 #--------------------------------------------------------#
 140
 141 sub chars {
 142   # ?... の配列を�����す
 143   my $self = shift;
 144   my @result = ('*');
 145   for my $attrname (keys %$self) {
 146     my @tmp = ();
 147     my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
 148     if (-f "$DB_HOME/$dbname/system-char-id") {
 149       @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $$self{$attrname}));
 150       @result = &cap(\@result, \@tmp);
 151     } elsif (-f "$DB_HOME/system-char-id/$dbname") {
 152       @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $$self{$attrname});
 153       @result = &cap(\@result, \@tmp);
 154     } else {
 155       die "cannot find $attrname: $! $BerkeleyDB::Error\n";
 156     }
 157   }
 158   return @result;
 159 }
 160
 161 sub getvalue ($$) {
 162   # キーから値を�����り出す
 163   my($dbname, $key) = @_;
 164   tie my %h, "BerkeleyDB::Hash",
 165     -Filename => $dbname;
 166   my $value = $h{$key};
 167   untie %h;
 168   return $value;
 169 }
 170
 171 sub getkeys ($$) {
 172   # 値からキーの配列を�����り出す
 173   my($dbname, $value) = @_;
 174   tie my %h, "BerkeleyDB::Hash",
 175     -Filename => $dbname;
 176   my @keys = ();
 177   for my $key (keys %h) {
 178     push @keys, $key if ($h{$key} eq $value);
 179   }
 180   untie %h;
 181   return @keys;
 182 }
 183
 184 sub cap {
 185   # 2つの配列の積�����合を求める
 186   my($a, $b) = @_;
 187   if (!@$a or !@$b) {
 188     return ();
 189   } elsif ($$a[0] eq '*') { # '*'は全体�����合
 190     return @$b;
 191   } elsif ($$b[0] eq '*') {
 192     return @$a;
 193   } else {
 194     my %result = ();
 195     my @result = ();
 196     for my $i (@$a, @$b) {
 197       $result{$i}++;
 198       push @result, $i if ($result{$i} == 2);
 199     }
 200     return @result;
 201     #return grep {
 202     #  my $c = $_;
 203     #  grep /^$c$/, @$b;
 204     #} @$a;
 205   }
 206 }
 207
 208 sub cup {
 209   # 2つの配列の和�����合を求める
 210   my %result = ();
 211   for my $i (@_) { $result{$i}++; }
 212   return keys %result;
 213 }
 214
 215 #--------------------------------------------------------#
 216 1;