#
# CHISE.pm by Shigeki Moro
# $Id: CHISE.pm,v 1.2 2003-02-23 09:17:19 moro Exp $
#
package CHISE;

use strict;
use BerkeleyDB;

my $DB_HOME = '/usr/local/lib/xemacs-21.4.10/i686-pc-linux/char-db';

my %alias = ();
my %alias_reverse = ();
for (glob "$DB_HOME/system-char-id/*") {
  s/^.*\/([^\/]+)$/$1/;
  my $i = $_;
  s/\->/to_/;
  s/<\-/from_/;
  s/=>/map_/;
  s/\-/_/g;
  $alias{$_} = $i;
  $alias_reverse{$i} = $_;
}
%alias = (
	  %alias,
	  'radical','ideographic-radical',
	  'strokes','total-strokes',
);

#--- exportã™ã‚‹äºˆø½ŠªŸã®é–¢æ•° -------------------------------------#

sub new {
  # æ—¢å­˜ã®ø½Š²¡å­—ã‚ªãƒ–ã‚¸ã‚§ã‚¯ãƒˆã®ç”Ÿæˆ
  my $invocant = shift;
  my $class = ref($invocant) || $invocant;
  my $self  = { @_ };
  bless $self, $class;
  my $key = ($self->chars)[0]; # è¦ã‚¨ãƒ©ãƒ¼ãƒã‚§ãƒƒã‚¯
  my($value, $result);
  for my $dbname (glob "$DB_HOME/system-char-id/*") {
    $value = &getvalue($dbname, $key);
    if ($value) {
      $dbname =~ s/^.*\/([^\/]+)$/$1/;
      $result->{$alias_reverse{$dbname}} = $value;
    }
  }
  return bless $result, $class;
}

sub define_char {
  # ø½Š¢–ã—ã„ø½Š²¡å­—ã‚ªãƒ–ã‚¸ã‚§ã‚¯ãƒˆã®ç”Ÿæˆ
  my $invocant = shift;
  my $class = ref($invocant) || $invocant;
  my $self = {@_};
  my $result = ();
  for my $i (keys %$self) {
    $result->{$alias_reverse{$alias{$i}}} = $$self{$i};
  }
  return bless $result, $class;
}

sub dumpAttr {
  # ø½Š²¡å­—ã‚ªãƒ–ã‚¸ã‚§ã‚¯ãƒˆãŒæŒã£ã¦ã„ã‚‹å…¨å±žæ€§ã‚’print
  my $self = shift;
  for my $i (keys %$self) {
    print "$i => $$self{$i}\n";
  }
}

sub addAttr {
  # ø½Š²¡å­—ã‚ªãƒ–ã‚¸ã‚§ã‚¯ãƒˆã«å±žæ€§ã‚’è¿½åŠ 
  my $model = shift;
  my $self = $model->define_char(%$model, @_);
  return $self;
}

sub delAttr (@) {
  # ø½Š²¡å­—ã‚ªãƒ–ã‚¸ã‚§ã‚¯ãƒˆã‹ã‚‰å±žæ€§ã‚’å‰Šé™¤
  my $model = shift;
  delete $$model{$_} foreach (@_);
  my $self = $model->define_char(%$model);
  return $self;
}

# å±žæ€§åã§å±žæ€§å€¤ã‚’ø½Š²¿ã™
# ä¾‹: $s->morohashi_daikanwa
# cf. get_char_attribute
for my $attrname (keys %alias) {
  my $slot = __PACKAGE__ . "::$attrname";
  no strict "refs";
  *$slot = sub {
    my $self = shift;
    my $dbname = exists $alias{$attrname}
      ? $alias_reverse{$alias{$attrname}}
      : $attrname;
    return $self->{$dbname};
  }
}
#for my $attrname (keys %alias) {
#  my $slot = __PACKAGE__ . "::$attrname";
#  no strict "refs";
#  *$slot = sub {
#    my $self = shift;
#    my @result;
#    for my $i ($self->chars) {
#      my $j = &getvalue("$DB_HOME/system-char-id/$alias{$attrname}", $i);
#      push @result, $j if $j;
#    }
#    return @result;
#  }
#}

sub compare {
  # ø½Š²¡å­—ã‚ªãƒ–ã‚¸ã‚§ã‚¯ãƒˆã¨æ¯”ø½Š‘Š
  my($a, $b) = @_;
  my($all_attr, $common_attr) = (0, 0);
  for my $i (&cup(keys %$a, keys %$b)) {
    if ($a->{$i} eq $b->{$i}) {
      $all_attr++;
      $common_attr++;
    } else {
      $all_attr++ if (exists $a->{$i});
      $all_attr++ if (exists $b->{$i});
    }
  }
  return $all_attr ? ($common_attr / $all_attr) : 0;
}

sub ph2char ($) {
  # ø½Šž‡ä½“å‚ç…§ã‹ã‚‰?xã‚’å¾—ã‚‹
  my $ph = shift;
  my %alias = (
	       'C1','chinese-cns11643-1',
	       'C2','chinese-cns11643-2',
	       'C3','chinese-cns11643-3',
	       'C4','chinese-cns11643-4',
	       'C5','chinese-cns11643-5',
	       'C6','chinese-cns11643-6',
	       'C7','chinese-cns11643-7',
	       'CB','ideograph-cbeta',
	       'CDP','chinese-big5-cdp',
	       'GT','ideograph-gt',
	       'GT-K','ideograph-gt',
	       'HZK1','ideograph-hanziku-1',
	       'HZK2','ideograph-hanziku-2',
	       'HZK3','ideograph-hanziku-3',
	       'HZK4','ideograph-hanziku-4',
	       'HZK5','ideograph-hanziku-5',
	       'HZK6','ideograph-hanziku-6',
	       'HZK7','ideograph-hanziku-7',
	       'HZK8','ideograph-hanziku-8',
	       'HZK9','ideograph-hanziku-9',
	       'HZK10','ideograph-hanziku-10',
	       'HZK11','ideograph-hanziku-11',
	       'HZK12','ideograph-hanziku-12',
	       'J78','japanese-jisx0208-1978',
	       'J83','japanese-jisx0208',
	       'J90','japanese-jisx0208-1990',
	       'JSP','japanese-jisx0212',
	       'JX1','japanese-jisx0213-1',
	       'JX2','japanese-jisx0213-2',
	       'K0','korean-ksc5601',
	       'M','ideograph-daikanwa',
	      );
  my $keys = join '|', sort keys %alias;
  my($phname, $phvalue) = ($ph =~ /^\&(?:I\-)?($keys)\-?([0-9a-f]+);$/i);
  if (exists $alias{$phname}) {
    if ($alias{$phname} =~ /daikanwa|gt/) {
      $phvalue =~ s/^0+//;
    } else {
      $phvalue = "0x$phvalue";
    }
    tie my %h, "BerkeleyDB::Hash",
      -Filename => "$DB_HOME/$alias{$phname}/system-char-id"
      or die "Cannot open file $alias{$phname}: $! $BerkeleyDB::Error\n";
    if (exists $h{$phvalue}) {
      return $h{$phvalue};
    } else {
      #print STDERR "\tCan't convert $phname - $phvalue (no value in db).\n";
      return $ph;
    }
    untie %h;
  } else {
    #print STDERR "\tCan't convert $phname - $phvalue.\n";
    return $ph;
  }
}

#--- ãƒ¢ã‚¸ãƒ¥ãƒ¼ãƒ«å†…ã®ã¿ã§ø»‚¢³ã†äºˆø½ŠªŸã®é–¢æ•° ----------------------#

sub chars {
  # ?... ã®é…åˆ—ã‚’ø½Š²¿ã™
  my $self = shift;
  my @result = ('*');
  for my $attrname (keys %$self) {
    my @tmp = ();
    my $dbname = exists $alias{$attrname} ? $alias{$attrname} : $attrname;
    if (-f "$DB_HOME/$dbname/system-char-id") {
      @tmp = (&getvalue("$DB_HOME/$dbname/system-char-id", $$self{$attrname}));
      @result = &cap(\@result, \@tmp);
    } elsif (-f "$DB_HOME/system-char-id/$dbname") {
      @tmp = &getkeys("$DB_HOME/system-char-id/$dbname", $$self{$attrname});
      @result = &cap(\@result, \@tmp);
    } else {
      die "cannot find $attrname: $! $BerkeleyDB::Error\n";
    }
  }
  return @result;
}

sub utf8 {
  # UTF-8ã‚’ø½Š²¿ã™
  my $self = shift;
  my @result;
  for my $i ($self->chars) {
    $i =~ s/^\?//;
    # To Do: ç§ç”¨ø½Š¸¯åŸŸã®ã¯ø½Š²¿ã•ãªã„ã‚ˆã†ã«ã—ãªã„ã¨ã€‚
    push @result, $i;
  }
  return @result;
}

sub getvalue ($$) {
  # ã‚­ãƒ¼ã‹ã‚‰å€¤ã‚’ø½Šž­ã‚Šå‡ºã™
  my($dbname, $key) = @_;
  tie my %h, "BerkeleyDB::Hash",
    -Filename => $dbname;
  my $value = $h{$key};
  untie %h;
  return $value;
}

sub getkeys ($$) {
  # å€¤ã‹ã‚‰ã‚­ãƒ¼ã®é…åˆ—ã‚’ø½Šž­ã‚Šå‡ºã™
  my($dbname, $value) = @_;
  tie my %h, "BerkeleyDB::Hash",
    -Filename => $dbname;
  my @keys = ();
  for my $key (keys %h) {
    push @keys, $key if ($h{$key} eq $value);
  }
  untie %h;
  return @keys;
}

sub cap {
  # 2ã¤ã®é…åˆ—ã®ç©ø½ŠŸ›åˆã‚’æ±‚ã‚ã‚‹
  my($a, $b) = @_;
  if (!@$a or !@$b) {
    return ();
  } elsif ($$a[0] eq '*') { # '*'ã¯å…¨ä½“ø½ŠŸ›åˆ
    return @$b;
  } elsif ($$b[0] eq '*') {
    return @$a;
  } else {
    my %result = ();
    my @result = ();
    for my $i (@$a, @$b) {
      $result{$i}++;
      push @result, $i if ($result{$i} == 2);
    }
    return @result;
    #return grep {
    #  my $c = $_;
    #  grep /^$c$/, @$b;
    #} @$a;
  }
}

sub cup {
  # 2ã¤ã®é…åˆ—ã®å’Œø½ŠŸ›åˆã‚’æ±‚ã‚ã‚‹
  my %result = ();
  for my $i (@_) { $result{$i}++; }
  return keys %result;
}

#--------------------------------------------------------#
1;
