漢数字電卓

某所で必要だったので，漢数字電卓用のモジュールを作っていました．漢数字をアラビア数字に変換したり，アラビア数字を漢数字に変換するものです．そろそろできあがったかな，と思っていたら弾さんがLingua-JA-Numbers-0.05 - Converts numeric values into their Japanese string equivalents and vice versa - metacpan.orgというモジュールを作られたので，さっそくお蔵入りになりました．(T^T) このまま捨ててしまうのももったいないので，ここにさらします．

漢数字の表現は，一 二 三 四 五 六 七 八 九 十 百 千 万 億 兆 京 垓 禾予 穣 溝 澗 正 載 極 恒河沙 阿僧祇 那由多 不可思議 無量大数を使っています．万から極までは万進(10^4)，恒河沙から無量大数までは万万進(10^8)です．

package JANumbers;
use base qw(Exporter);
use encoding 'shiftjis';
use bignum;
use strict;

our @EXPORT = qw(arabic2chinese chinese2arabic);

## 構造定義
#

my ($tag1, $tag2, $tag3, $digit, @num1, @num2, @num3, @num4, %table);

$tag1  = q{(?:千|百|十|\b)};
$tag2  = q{(?:載|正|澗|溝|穣|禾予|垓|京|兆|億|万|\b)};
$tag3  = q{(?:無量大数|不可思議|那由多|阿僧祇|恒河沙|極|\b)};
$digit = q{(?:一|二|三|四|五|六|七|八|九)};

@num1 = qw(一 二 三 四 五 六 七 八 九);
@num2 = qw(十 百 千);
@num3 = qw(万 億 兆 京 垓 予禾 穣 溝 澗 正 載); # 禾予を逆にしている
@num4 = qw(極 恒河沙 阿僧祇 那由多 不可思議 無量大数);

unshift @num1, '';
unshift @num2, '';
unshift @num3, '';

%table = (
	'一' => 1, '二' => 2, '三' => 3, '四' => 4,
	'五' => 5, '六' => 6, '七' => 7, '八' => 8, '九' => 9,
	'十' => 10, '百' => 10**2, '千' => 10**3,
	'万' => 10**4, '億' => 10**8, '兆' => 10**12,
	'京' => 10**16, '垓' => 10**20, '禾予' => 10**24,
	'穣' => 10**28, '溝' => 10**32, '澗' => 10**36,
	'正' => 10**40, '載' => 10**44,
	'極' => 10**48, '恒河沙' => 10**56,
	'阿僧祇' => 10**64, '那由多' => 10**72,
	'不可思議' => 10**80, '無量大数' => 10**88,
);

## _fourchar($)
#	万進の数字処理
#	文字列 $str を渡すと数字を返す
#
sub _fourchar($)
{
	my $str = shift;
	my $ret;

	while ($str =~ /($digit)?($tag1)/g){
		my $block = $table{$1};       # 二千だったら 二
		my $unit  = $table{$2};       # 二千だったら 千

		## 桁表記があるのに漢数字がない
		#     1 x 10^n の時
		#
		$block = 1 if (!$block && $unit);

		## 漢数字があるのに桁表記がない
		#     n x 1 の時
		#
		$unit  = 1 if ($block && !$unit);
		$ret += $block * $unit;
	}
	return $ret;
}

## _eightchar($)
#	万万進の数字処理
#	文字列 $str を渡すと数字を返す
#
sub _eightchar($)
{
	my $str = shift;
	my $ret;

	while ($str =~ /([^$tag2]+)($tag2)/g){
		my $block = _fourchar($1);
		my $unit  = $table{$2} || 1;
		$ret += $block * $unit;
	}
	return $ret;
}

## chinese2arabic($)
#	漢数字をアラビア数字に変換
#	文字列 $str を渡すと数字を返す
#
sub chinese2arabic($)
{
	my $str = shift;
	my $ret;

	while ($str =~ /([^$tag3]+)($tag3)/g){
		my $block = _eightchar($1);
		my $unit  = $table{$2} || 1;
		$ret += $block * $unit;
	}
	return $ret;
}

## _expo($$)
#	数字 $num と桁 $pos を渡すと文字列を返す
#
sub _expo($$)
{
	my $num = shift;
	my $pos = shift;
	my $ret;
	return '' if ($num == 0);
	return '一' if (($num == 1) && ($pos == 0));
	return $num2[$pos] if (($num == 1) && ($pos > 0));
	return $num2[$pos] . $num1[$num];
}

## _fourdigit($)
#	万進の漢数字処理
#	数字 $num を渡すと文字列を返す
#
sub _fourdigit($)
{
	my $num = shift;
	my ($pos1, $ret);
	map{
		my $pos2;
		$ret .= $num3[$pos1++];
		s/(\d)/_expo($1, $pos2++)/eg;
		$ret .= $_;
	}(reverse($num) =~ /\d{1,4}/g);
	return $ret = reverse($ret);
}

## _eightdigit($)
#	万万進の漢数字処理
#	数字 $num を渡すと文字列を返す
#
sub _eightdigit($)
{
	my $num = shift;
	my ($pos1, $ret);
	map{
		$ret = _fourdigit(reverse($_)) . $num4[$pos1++] . $ret;
	}(reverse($num) =~ /\d{1,8}/g);
	return $ret;
}

## arabic2chinese($)
#	アラビア数字を漢数字に変換
#	数字 $num を渡すと文字列を返す
sub arabic2chinese($)
{
	my $num = shift;
	my ($fourdigit, $eightdigit);
	$num =~ /(\d{0,48}?)$/;
	return _eightdigit($`) . _fourdigit($1);
}
1;

解説がいるかな？と思いつつ，このブログを見てるひとはそんなにいないだろうから，放置．あ，WinXP + Activestate上で作っていたので，文字コードにshiftjisを指定しています．