File Coverage

blib/lib/Lingua/TR/Numbers.pm

Criterion	Covered	Total	%
statement	148	158	93.6
branch	62	82	75.6
condition	19	33	57.5
subroutine	26	28	92.8
pod	2	2	100.0
total	257	303	84.8

package Lingua::TR::Numbers;
use 5.006;
use utf8;
use strict;
use warnings;
use subs qw( _log );

our $VERSION = '0.32';

use constant RE_E2TR => qr{
    \A
    (
        [-+]?  # leading sign
        (?:
        [\d,]+  |  [\d,]*\.\d+  # number
        )
    )
    [eE]
    (-?\d+)   # mantissa, has to be an integer
    \z
}xms;
use constant RE_EMPTY     => qr//xms;
use constant EMPTY_STRING => q{};
use constant SPACE        => q{ };
use constant DIGITS       => 0..9;
use constant TENS         => map { 10 * $_ } 1..9;
use constant LAST_ELEMENT => -1;
use constant PREV_ELEMENT => -2;
use constant CHUNK_MAX    => 100;
use base qw( Exporter );
use Carp qw( croak );

BEGIN { *DEBUG = sub () {0} if ! defined &DEBUG } # setup a DEBUG constant

our @EXPORT_OK   = qw( num2tr num2tr_ordinal );
our %EXPORT_TAGS =   ( all => \@EXPORT_OK    );

my($RE_VOWEL, %D, %MULT, %CARD2ORD, %CARD2ORDTR);

POPULATE: {
    @D{ DIGITS() } = qw| sıfır bir     iki    üç     dört     beş     altı    yedi    sekiz     dokuz     |;
    @D{ TENS()   } = qw|       on      yirmi  otuz   kırk     elli    altmış  yetmiş  seksen    doksan    |;

    @CARD2ORD{       qw|       bir     iki    üç     dört     beş     altı    yedi    sekiz     dokuz     |}
                   = qw|       birinci ikinci üçüncü dördüncü beşinci altıncı yedinci sekizinci dokuzuncu |;

    @CARD2ORDTR{     qw| a   e   ı   i   u   ü   o   ö   |}
                   = qw| ncı nci ncı nci ncu ncü ncu ncü |;

    $RE_VOWEL = join EMPTY_STRING, keys %CARD2ORDTR;
    $RE_VOWEL = qr{([$RE_VOWEL])}xms;

    my @large = qw|
                   bin       milyon    milyar    trilyon  katrilyon
                   kentilyon seksilyon septilyon oktilyon nobilyon
                   desilyon
                |;
    my $c = 0;
    $MULT{ $c++ } = $_ for EMPTY_STRING, @large;
}

sub num2tr_ordinal {
    #  Cardinals are [bir     iki    üç     ...]
    #  Ordinals  are [birinci ikinci üçüncü ...]
    my $x = shift;

    return unless defined $x and length $x;

    $x = num2tr( $x );
    return $x if ! $x;

    my($ok, $end, $step);
    if ( $x =~ s/(\w+)\z//xms ) {
        $end  = $1;
        my @l = split RE_EMPTY, $end;
        $step = 1;

        foreach my $l ( reverse @l ) {
            next if not $l;
            if ( $l =~ $RE_VOWEL ) {
                $ok = $1;
                last;
            }
            $step++;
        }
    }
    else {
        return $x . q{.};
    }

    if ( ! $ok ) {
        #die "Can not happen: '$end'";
        return;
    }

    $end = $CARD2ORD{$end} || sub {
                                my $val = $CARD2ORDTR{$ok};
                                return $end . $val if $step == 1;
                                my $letter = (split RE_EMPTY, $val)[LAST_ELEMENT];
                                return $end.$letter.$val;
                            }->();

    return "$x$end";
}

sub num2tr {
    my $x = shift;
    return unless defined $x and length $x;

    return 'sayı-değil'  if $x eq 'NaN';
    return 'eksi sonsuz' if $x =~ m/ \A \+ inf(?:inity)? \z /xmsi;
    return 'artı sonsuz' if $x =~ m/ \A \- inf(?:inity)? \z /xmsi;
    return      'sonsuz' if $x =~ m/ \A    inf(?:inity)? \z /xmsi;
    return $D{$x}        if exists $D{$x};  # the most common cases

    # Make sure it's not in scientific notation:
    { my $e = _e2tr($x); return $e if defined $e; }

    my $orig = $x;

    $x =~ s/,//xmsg; # nix any commas

    my $sign;
    if ( $x =~ s/\A([-+])//xms ) {
        $sign = $1;
    }

    my($int, $fract);
       if( $x =~ m/ \A          \d+  \z/xms ) { $int = $x }
    elsif( $x =~ m/ \A (\d+)[.](\d+) \z/xms ) { $int = $1; $fract = $2 }
    elsif( $x =~ m/ \A      [.](\d+) \z/xms ) { $fract = $1 }
    else {
        _log "Not a number: '$orig'\n" if DEBUG;
        return;
    }

    _log(
        sprintf " Working on Sign[%s]  Int2tr[%s]  Fract[%s]  < '%s'\n",
                map { defined($_) ? $_ : 'nil' } $sign, $int, $fract, $orig
    ) if DEBUG;

    return join SPACE, grep { defined $_ && length $_ }
                            _sign2tr(  $sign  ),
                            _int2tr(   $int   ),
                            _fract2tr( $fract ),
    ;
}

sub _sign2tr {
    my $x = shift;
    return ! defined $x || ! length $x ? undef
         : $x eq q{-}                  ? 'eksi'
         : $x eq q{+}                  ? 'artı'
         :                               "WHAT_IS_$x"
         ;
}

sub _fract2tr { # "1234" => "point one two three four"
    my $x = shift;
    return unless defined $x and length $x;
    return join SPACE, 'nokta',
                        map { $D{$_} }
                            split RE_EMPTY, $x;
}

# The real work:

sub _int2tr {
    my $x = shift;
    return unless defined $x and length $x and $x =~ m/\A\d+\z/xms;
    return $D{$x} if defined $D{$x}; # most common/irreg cases

    if( $x =~ m/\A(.)(.)\z/xms ) {
        return  $D{$1 . '0'} . SPACE . $D{$2};
        # like    forty        -     two
        # note that neither bit can be zero at this point
    }
    elsif ( $x =~ m/\A(.)(..)\z/xms ) {
        my $tmp = $1 == 1 ? EMPTY_STRING : $D{$1} . SPACE;
        my($h, $rest) = ($tmp.'yüz', $2);
        return $h if $rest eq '00';
        return "$h " . _int2tr(0 + $rest);
    }
    else {
        return _bigint2tr($x);
    }
}

sub _bigint2tr {
    my $x = shift;
    return unless defined $x and length $x and $x =~ m/\A\d+\z/xms;
    my @chunks;  # each:  [ string, exponent ]
    {
        my $groupnum = 0;
        my $num;
        while ( $x =~ s/(\d{1,3})\z//xms ) { # pull at most three digits from the end
            $num = $1 + 0;
            unshift @chunks, [ $num, $groupnum ] if $num;
            ++$groupnum;
        }
        return $D{'0'} unless @chunks;  # rare but possible
    }

    my $and;
    # junk
    $and = EMPTY_STRING if $chunks[LAST_ELEMENT][1] == 0 and $chunks[LAST_ELEMENT][0] < CHUNK_MAX;
    # The special 'and' that shows up in like "one thousand and eight"
    # and "two billion and fifteen", but not "one thousand [*and] five hundred"
    # or "one million, [*and] nine"

    _chunks2tr( \@chunks );

    $chunks[PREV_ELEMENT] .= SPACE if $and and @chunks > 1;
    return "$chunks[0] $chunks[1]" if @chunks == 2;
    # Avoid having a comma if just two units
    return join q{, }, @chunks;
}

sub _chunks2tr {
    my $chunks = shift;
    return if ! @{ $chunks };
    my @out;
    foreach my $c ( @{ $chunks } ) {
        push @out,   $c = _groupify( _int2tr( $c->[0] ),  $c->[1] ,$c->[0])  if $c->[0];
    }
    @{ $chunks } = @out;
    return;
}

sub _groupify {
    # turn ("seventeen", 3) => "seventeen billion"
    my($basic, $multnum, $raw) = @_;
    return  $basic unless $multnum;  # the first group is unitless
    _log "  Groupifying $basic x $multnum mults\n" if DEBUG > 2;
    return "$basic $MULT{$multnum}"  if  $MULT{$multnum};
    # Otherwise it must be huuuuuge, so fake it with scientific notation
    return $basic . ' çarpı on üzeri ' . num2tr( $raw * 3 );
}

# Because I can never remember this:
#
#  3.1E8
#  ^^^   is called the "mantissa"
#      ^ is called the "exponent"
#         (the implicit "10" is the "base" a/k/a "radix")

sub _e2tr {
    my $x = shift;
    if ( $x =~ RE_E2TR ) {
        my($m, $e) = ($1, $2);
        _log "  Scientific notation: [$x] => $m E $e\n" if DEBUG;
        $e += 0;
        return num2tr($m) . ' çarpı on üzeri ' . num2tr($e);
    }
    else {
        _log "  Okay, $x isn't in exponential notation\n" if DEBUG;
        return;
    }
}

sub _log {
    my @args = @_;
    print @args or croak "Unable to print to STDOUT: $!";
    return;
}

#==========================================================================

1;

__END__