2 # CHISE.pm by Shigeki Moro
3 # $Id: CHISE.pm,v 1.6 2003-10-08 13:30:28 moro Exp $
12 our ($EXCLUSIVE, $HAVE_INTERSECTION, $PROPER_SUBSET, $PROPER_SUPERSET, $EQSET);
13 ($EXCLUSIVE, $HAVE_INTERSECTION, $PROPER_SUBSET, $PROPER_SUPERSET, $EQSET)
16 # データベースの場を指。いずれはlibchiseに...
17 # データベースの全ファイルをchownしないとえないかも
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';
38 print STDERR "CHISE.pm: No database found.\n";
39 print STDERR "CHISE.pm: Please set \$DB_HOME to CHISE.pm.\n";
44 my %alias_reverse = ();
45 for (glob "$DB_HOME/system-char-id/*") {
48 s/^\->/to_/; # Perlではリファレンスに
49 s/^<\-/from_/; # "-" などがえないため、しておく。
54 $alias_reverse{$i} = $_;
58 'radical','ideographic-radical',
59 'strokes','total-strokes',
62 #--- exportする予の関数 -------------------------------------#
67 my $class = ref($invocant) || $invocant;
70 my $key = ($self->chars)[0]; # 要エラーチェック
72 for my $dbname (glob "$DB_HOME/system-char-id/*") {
73 $value = &getvalue($dbname, $key);
75 $dbname =~ s/^.*\/([^\/]+)$/$1/;
76 $result->{$alias_reverse{$dbname}} = $value;
79 return bless $result, $class;
85 my $class = ref($invocant) || $invocant;
88 for my $i (keys %$self) {
89 $result->{$alias_reverse{$alias{$i}}} = $$self{$i};
91 return bless $result, $class;
95 # 字オブジェクトが持っている全属性をprint
97 for my $i (keys %$self) {
98 print "$i => $$self{$i}\n";
105 my $self = $model->define_char(%$model, @_);
112 delete $$model{$_} foreach (@_);
113 my $self = $model->define_char(%$model);
118 # 例: $s->morohashi_daikanwa
119 # cf. get_char_attribute
120 for my $attrname (keys %alias) {
121 my $slot = __PACKAGE__ . "::$attrname";
125 my $dbname = exists $alias{$attrname}
126 ? $alias_reverse{$alias{$attrname}}
128 return $self->{$dbname};
131 #for my $attrname (keys %alias) {
132 # my $slot = __PACKAGE__ . "::$attrname";
137 # for my $i ($self->chars) {
138 # my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
139 # push @result, $j if $j;
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}) {
155 $aonly++ if (exists $a->{$i});
156 $bonly++ if (exists $b->{$i});
159 $aonly++ if (exists $a->{$i});
160 $bonly++ if (exists $b->{$i});
164 return $EXCLUSIVE; # 他
165 } elsif ($aonly == 0 and $bonly == 0) {
167 } elsif ($aonly == 0) {
168 return $PROPER_SUBSET; # $aは$bの合
169 } elsif ($bonly == 0) {
170 return $PROPER_SUPERSET; # $bは$aの合
172 return $HAVE_INTERSECTION;
176 sub rate_of_coincidence {
177 # 字オブジェクトどうしの属性の一致を出す。
179 my($all_attr, $common_attr) = (0, 0);
180 for my $i (&cup(keys %$a, keys %$b)) {
181 if ($a->{$i} eq $b->{$i}) {
185 $all_attr++ if (exists $a->{$i});
186 $all_attr++ if (exists $b->{$i});
189 return $all_attr ? ($common_attr / $all_attr) : 0;
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',
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',
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/) {
234 $phvalue = "0x$phvalue";
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}) {
242 #print STDERR "\tCan't convert $phname - $phvalue (no value in db).\n";
247 #print STDERR "\tCan't convert $phname - $phvalue.\n";
252 #--- モジュール内のみでう予の関数 ----------------------#
258 for my $attrname (keys %$self) {
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);
268 die "cannot find $attrname: $! $BerkeleyDB::Error\n";
278 for my $i ($self->chars) {
280 # To Do: 私用域のはさないようにしないと。
288 my ($chise_dbname, $key) = @_;
290 tie (my %h, "DB_File", $chise_dbname, O_RDWR)
291 or die "Cannot open file $chise_dbname: $!\n";
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";
303 for my $key (keys %h) {
304 next unless (exists $h{$key});
305 push @keys, $key if ($h{$key} eq $value);
317 } elsif ($$a[0] eq '*') { # '*'は全体合
319 } elsif ($$b[0] eq '*') {
324 for my $i (@$a, @$b) {
326 push @result, $i if ($result{$i} == 2);
339 for my $i (@_) { $result{$i}++; }
343 #--------------------------------------------------------#