root/veekun/trunk/script/utils/convert_kana.pl

#!/usr/bin/perl

# Converts kana to my style of romaji, which is mostly wapuro.
# Provided as-is for my benefit later; no real documentation.
# Licensed the same as the rest of the veekun code, so feel free to rip out
# the transliterate() sub below.

use strict;
use warnings;

use DBI;
use Convert::EastAsianWidth;
use Encode;
use Storable qw/dclone/;

# courtesy of Lingua::JA::Romanize::Kana
my @kana = qw(
    xa  a   xi  i   xu  u   xe  e   xo  o   ka  ga  ki  gi  ku
    gu  ke  ge  ko  go  sa  za  shi ji  su  zu  se  ze  so  zo  ta
    da  chi ji  xtu tsu zu  te  de  to  do  na  ni  nu  ne  no  ha
    ba  pa  hi  bi  pi  fu  bu  pu  he  be  pe  ho  bo  po  ma  mi
    mu  me  mo  xya ya  xyu yu  xyo yo  ra  ri  ru  re  ro  xwa wa
    wi  we  wo  n   vu  ka  ke
);

my $dbh = DBI->connect('dbi:mysql:pokedex', 'perl', '');
my $rows_ref = $dbh->selectall_arrayref('SELECT id, name, name_jp, name_romaji FROM pokemon', { Slice => {} });
my $sth = $dbh->prepare('UPDATE pokemon SET name_romaji = ? WHERE id = ?');

my $mismatches = 0;

for my $row (@$rows_ref) {
    if (not $row->{name_jp}) {
        warn "$row->{name} has no kana!";
        next;
    }

    my $converted_romaji = transliterate($row->{name_jp});

    # male/female symbols; changed to be consistent with my English
    $converted_romaji =~ s/\x{2640}/ F/g;
    $converted_romaji =~ s/\x{2642}/ M/g;

    # capitalize Romanly
    $converted_romaji =~ s/ \b (\w) /\u$1/gx;

    if ($converted_romaji =~ /[^\x20-\xffx]/) {
        print "!!! NON-ASCII CHARACTERS DETECTED FOR $row->{name}; SKIPPING\n";
        next;
    }
    
    if ($row->{name_romaji} ne $converted_romaji) {
        $mismatches++;
        $sth->execute($converted_romaji, $row->{id});
        printf "Converted %12s: %16s -> %16s\n", $row->{name}, $row->{name_romaji}, $converted_romaji;
    }
}

print "$mismatches changed romaji\n";


# TODO: instead of the kana+chibivowel messiness, this should first go through
# and tag all the kana as katakana or hiragana, small or not, etc
sub transliterate {
    my ($bytes) = @_;
    my $string = decode('utf8', $bytes);
    $string = to_halfwidth($string);
    my @chars = split //, $string;

    for my $char (@chars) {
        my $codept = ord $char;

        if ($codept < 0x3041 or
            ($codept > 0x3093 and $codept < 0x30a1) or
            $codept > 0x30f6)
        {
            # outside our range!
            $char = [ $char, '' ];
            next;
        }

        my $idx = ($codept - 0x3041) % 96;
        $char = [ $char, $kana[$idx] ];
    }

    for my $i (1 .. $#chars) {
        # pa-paru
        if ($chars[$i][0] eq "\x{30fc}" and
            $chars[$i][0] ne $chars[$i - 1][0]
        ) {
            ( $chars[$i][1] ) = ( $chars[$i - 1][1] =~ /([aeiou])h?$/ );
        }
    }

    my $pos = $#chars;
    while ($pos >= 0) {
        # kana + chibi-vowel; used a lot in katakana
        if ($chars[$pos][1] =~ /x[aeiou]/) {
            my $vowel = $chars[$pos][1];
            $vowel =~ s/^x//;
            my $newchar = $chars[$pos - 1][1];

            if ($vowel eq substr $newchar, -1) {
                # special exception: sometimes this is used to double a vowel
                # (e.g. in serebii)
                $chars[$pos][1] = $vowel;
            } else {
                $newchar =~ s/[aeiou]$/$vowel/;
                splice @chars, $pos - 1, 2, [ 'replaced', $newchar ];
            }

            $pos -= 2;
            next;
        }

        # mini-y*; blend with preceding *i
        # TODO: errors?
        if ($chars[$pos][1] =~ /^xy/ and
            $chars[$pos - 1][1] =~ /i$/)
        {
            my $prefix = substr $chars[$pos - 1][1], 0, -1;
            my $suffix = substr $chars[$pos][1], 1;

            # toss the y in a few cases
            $suffix = substr $suffix, 1
                if $prefix eq 'j' or $prefix eq 'sh' or $prefix eq 'ch';

            my $newchar = $prefix . $suffix;
            splice @chars, $pos - 1, 2, [ 'replaced', $newchar ];
            $pos -= 2;
            next;
        }

        # mini-tsu; double next consonant
        # TODO: errors for the weird conditions?  what to do there?
        if ($chars[$pos][1] eq 'xtu' and
            $chars[$pos + 1][1] =~ /^[^xaeiou]/ and
            $chars[$pos + 1][1] ne 'n')
        {
            my $newchar =
                substr($chars[$pos + 1][1], 0, 1) .
                $chars[$pos + 1][1];
            splice @chars, $pos, 2, [ 'replaced', $newchar ];

            # only decrement by one because we're not consuming the prior char
            $pos--;
            next;
        }

        $pos--;
    }

    my $result = join '', map { $_->[1] || $_->[0] } @chars;

    # fullwidth garbage
    $result =~ tr[\x{ff21}-\x{ff3a}\x{ff41}-\x{ff5a}]
                 [A-Za-z];

    return $result;
}