package Text::Roman;
# ABSTRACT: Converts Roman algorism to integer numbers and the contrary, recognize algorisms

use strict;
use warnings 'all';
use utf8;

use base 'Exporter';
our @EXPORT = qw(roman roman2int isroman mroman2int ismroman);

our $VERSION = '3.02'; # VERSION



my @alg = split '', 'IVXLCDM';
my @alginf = (-1, 0, 0, 2, 2, 4, 4);
my %parsub = (
    IV  => 'A',
    IX  => 'B',
    XL  => 'E',
    XC  => 'F',
    CD  => 'G',
    CM  => 'H',
);
my %val = (
    I   => 1,
    V   => 5,
    X   => 10,
    L   => 50,
    C   => 100,
    D   => 500,
    M   => 1000,
    A   => 4,
    B   => 9,
    E   => 40,
    F   => 90,
    G   => 400,
    H   => 900,
);
my %maxpos = (
    I   => 2,
    V   => 3,
    X   => 29,
    L   => 39,
    C   => 299,
    D   => 399,
    M   => 2999,
    A   => 0,
    B   => 0,
    E   => 9,
    F   => 9,
    G   => 99,
    H   => 99,
);

my @valg;
for my $i (0 .. $#alg){
    $valg[$i] = $val{$alg[$i]};
}

sub roman_stx {
    my $x   = shift;
    my $aux = $$x;

    $$x = uc $$x;
    if ($$x eq $aux || lc $$x eq $aux){
        if ($$x =~ /^[IXCMVLD]+$/x && $$x !~ /([IXCM])\1{3,}|([VLD])\2+/x) {
            $$x =~ s/(IV|IX|XL|XC|CD|CM)/$parsub{$1}/gx;
            $$x !~ /[AB].*?I|[EF].*?X|[GH].*?C/x;
        } else {
            '';
        }
    } else {
        '';
    }
}


sub roman2int {
    my $x = shift;
    my ($at, $i);
    my $val = 0;
    my $ant = 0;
    my @U;

    if (&roman_stx(\$x)){
        @U = split('', $x);
        for ($i = $#U; $i >= 0; $i--) {
            $at = $val{$U[$i]};
            return '' if ($at < $ant);
            $val += $at;
            $ant = $at;
        }
        $val;
    } else {
        '';
    }
}


# allows '_' milhar syntax (LX_XXIII, L_X_XXIII)
sub mroman2int {
    my $x = shift;
    my $s = 0;
    my ($sroman, $aux);
    my $y = '';
    my @partes;

    @partes = split('_', $x);
    $sroman = pop @partes;
    for my $i (@partes){
        $y .= $i;
    }
    $aux = &roman2int($y);
    return '' if ($y =~ /^(I{1,3})$/x || !$aux);
    $s += $aux * 1000;
    $aux = &roman2int($sroman);
    return '' if (!$aux);
    $s + $aux;
}


# allows '_' milhar syntax (LX_XXIII, L_X_XXIII)
sub ismroman {
    my $x = shift;
    my ($sroman);
    my $y = '';
    my @partes;

    if ($x =~ /^[_IXCMVLD]+$/x) {
        @partes = split('_', $x);
        $sroman = pop @partes;
        for my $i (@partes) {
            $y .= $i;
        }
        return '' if ($y =~ /^(I{1,3})$/x || !&isroman($y));
        return &isroman($sroman);
    }
}


# same efect that (&roman2int($x)>0), but fasted
sub isroman {
    my $x = shift;
    my $y = $x;
    $x = uc $x;

    ($x eq $y || lc $x eq $y) && $x =~ /
        ^(M{1,3}(D(C{1,3}(L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3})))?|
        C{0,3}XC(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))))?|
        CD(XC(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))))?|
        (C{1,3}(L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3})))?|
        C{0,3}XC(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3})))))?|
        M{0,3}CM(XC(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))))?|
        (D(C{1,3}(L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3})))?|
        C{0,3}XC(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))))?|
        CD(XC(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))))?|
        (C{1,3}(L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3})))?|
        C{0,3}XC(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (L(X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        XL(IX|
        (VI{0,3}|
        IV|
        I{1,3}))?|
        (X{1,3}(VI{0,3}|
        IV|
        I{1,3})?|
        X{0,3}IX|
        (VI{0,3}|
        IV|
        I{1,3}))))))$
    /x;
}

sub roman_div {
    my ($a, $b) = @_;
    my $inf = $alginf[$b];

    if ($b < 0) {
        (0, -1);
    } elsif (int($a / $valg[$b]) > 0) {
        ($b, -1);
    } elsif ($a + $valg[$inf] >= $valg[$b]) {
        ($b, $inf);
    } else {
        &roman_div($a, $b - 1);
    }
}

sub roman_do {
    my ($x, $str_x) = @_;
    my ($aux, $inf);

    ($aux, $inf) = &roman_div($x, $#alg);
    if ($x > 0 && $inf < 0) {
        &roman_do($x - $valg[$aux], $str_x . $alg[$aux]);
    } elsif ($x > 0 && $inf >= 0) {
        &roman_do($x + $valg[$inf] - $valg[$aux], $str_x . $alg[$inf] . $alg[$aux]);
    } else {
        $str_x;
    }
}


sub roman {
    my ($x) = @_;
    if ($x < 1 || $x > 3999){
        '';
    } else {
        roman_do($x, "");
    }
}

1;



=pod

=encoding utf8

=head1 NAME

Text::Roman - Converts Roman algorism to integer numbers and the contrary, recognize algorisms

=head1 VERSION

version 3.02

=head1 SYNOPSIS

    use Text::Roman;

    my $roman = "XXXV";
    my $mroman = 'L_X_XXIII';
    print roman(123), "\n";
    print roman2int($roman), "\n" if isroman($roman);
    print mroman2int($mroman), "\n" if ismroman($mroman);

=head1 DESCRIPTION

C<Text::Roman::roman()> is a very simple algorism converter.
It converts a single integer (in Arabic algorisms) at a time to its Roman correspondent.
The conventional Roman numbers goes from 1 up to 3999. MROMANS (milhar romans) range is 1 up to I<3999 * 1000 + 3999 = 4002999>.

There is no concern for mix cases, like 'Xv', 'XiiI', as legal Roman algorism numbers.

=head1 FUNCTIONS

=head2 roman2int($str)

Return '' if C<$str> is not Roman or return integer if it is.

=head2 mroman2int($str)

Return '' if C<$str> is not Roman or return integer if it is.
(milhar support)

=head2 ismroman($str)

Verify whether the given string is a milhar Roman number, if it is return 1; if it is not return 0.

=head2 isroman($str)

Verify whether the given string is a conventional Roman number, if it is return 1; if it is not return 0.

=head2 roman($int)

Return string containing the Roman corresponding to the given integer, or '' if the integer is out of domain.

=for Pod::Coverage roman_stx
roman_div
roman_do

=head1 SPECIFICATION

Roman number has origin in following BNF-like formula:

    a = I{1,3}
    b = V\a?|IV|\a
    e = X{1,3}\b?|X{0,3}IX|\b
    ee = IX|\b
    f = L\e?|XL\ee?|\e
    g = C{1,3}\f?|C{0,3}XC\ee?|\f
    gg = XC\ee?|\f
    h = D\g?|CD\gg?|\g
    j = M{1,3}\h?|M{0,3}CM\gg?|\h

=head1 REFERENCES

Specification supplied by redactor's manual of newspaper "O Estado de São Paulo".
URL: L<http://web.archive.org/web/20020819094718/http://www.estado.com.br/redac/norn-nro.html>

=head1 AUTHOR

Stanislaw Pusep <stas@sysd.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2000 by Peter de Padua Krauss <krauss@ifqsc.sc.usp.br>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut


__END__

