File Coverage

blib/lib/Number/Convert/Roman.pm

Criterion	Covered	Total	%
statement	9	64	14.0
branch	0	26	0.0
condition	0	9	0.0
subroutine	3	6	50.0
pod	3	3	100.0
total	15	108	13.8

package Number::Convert::Roman;

# Number::Convert::Roman - Roman-Arabic numeral converter

# Copyright (c) 2015 José Santos. All rights reserved.
# This program is free software. It can be redistributed and/or modified under
# the same terms as Perl itself.

use 5.006;
use strict;
use warnings;

our $VERSION = '0.01';

my %ROMAN_ARABIC = ('I' => 1, 'V' => 5, 'X' => 10, 'L' => 50,
										'C' => 100, 'D' => 500, 'M' => 1000);
my %ARABIC_ROMAN = map { $ROMAN_ARABIC{$_} => $_ } keys %ROMAN_ARABIC;
my ($THOUSANDS_OPEN, $THOUSANDS_CLOSE) = ('(', ')');

sub new { bless {}, shift; }

sub arabic {
	shift;
	my @roman = split //, shift;
	my ($number, $sum, $last, $thousands) = (0, 0, 0, 0);
	for (my $i = $#roman; $i >= 0; $i--) {
		if ($roman[$i] !~ /[$THOUSANDS_CLOSE$THOUSANDS_OPEN]/) {
			$number = $ROMAN_ARABIC{$roman[$i]};
			$sum += ($number >= $last ? 1 : -1) * ($number * 1000 ** $thousands);
			$last = $number;
		} elsif ($roman[$i] eq $THOUSANDS_CLOSE) {
			$last = 0;
			$thousands++;
		}
	}
	$sum;
}

sub roman {
	shift;
	my ($i, @arabic) = (-1, split //, shift);
	my @numbers = map { $i++; $_ > 0 ? $_ . '0' x ($#arabic - $i) : () } @arabic;
	my ($prefix, $x, $y, $first, $thousands, $zerofill);
	# break each number using roman logic and underscore prefix each power of 1000
	# e.g. 1000 -> _1; 3000 -> _1, _1, _1; 4000 -> _1, _5; 5000000 -> __5
	for ($i = 0; $i <= $#numbers; $i++) {
		$prefix = '';
		$first = substr $numbers[$i], 0, 1;
		$thousands = int(log($numbers[$i] / $first) / log(1000));
		$prefix = '_' x $thousands;
		$numbers[$i] /= 1000 ** $thousands;
		$zerofill = '0' x ((length $numbers[$i]) - 1);
		if ($first == 1 || $first == 5) {
			$numbers[$i] = $prefix . $numbers[$i];
		} elsif ($first >= 2 && $first <= 3) {	# replace [2-3]0* by 2-3 x _+10*
			splice @numbers, $i, 1;
			for (1 .. $first) {
				splice @numbers, $i, 0, $prefix . 1 . $zerofill;
			}
			$i += $first - 1;
		} elsif ($first == 4) {	# replace 40* by 10* and 50*
			splice @numbers, $i, 1;
			splice @numbers, $i++, 0, $prefix . 1 . $zerofill, $prefix . 5 . $zerofill;
		} elsif ($first >= 6 and $first <= 8) {	# replace [6-8]0* by 50* + 1-3 x +10*
			splice @numbers, $i, 1;
			for (6 .. $first) {
				splice @numbers, $i, 0, $prefix . 1 . $zerofill;
			}
			splice @numbers, $i, 0, $prefix . 5 . $zerofill;
			$i += ($first - 5);
		} elsif ($first == 9) {	# replace 90* by 10* and 50*
			splice @numbers, $i, 1;
			splice @numbers, $i++, 0, $prefix . 1 . $zerofill, $prefix . 10 . $zerofill;
		}
	}
	# replace each underscore prefixed number by its parenthesis surrounded version
	# e.g. _1 -> (I); _1, _1, _1 -> (III); _1, _5 -> (IV); __5 -> ((V))
	my ($result, $previous_level, $level, $number) = ('', -1, 0, '');
	for (@numbers) {
		($prefix, $number) = m/(_*)(.+)/;
		$level = length $prefix;
		if ($level != $previous_level) {
			if ($level < $previous_level) {
				$result .= $THOUSANDS_CLOSE x ($previous_level - $level);
			} elsif ($level > $previous_level) {
				$result .= '(' x $level;
			}
			$previous_level = $level;
		}
		$result .= $ARABIC_ROMAN{$number};
	}
	if ($level eq $previous_level) {
		$result .= $THOUSANDS_CLOSE x $level;
	}
	# replace all (I), (II) and (III) by M, MM and MMM, respectively
	$result =~ s/\((I+)\)/'M' x length $1/ge;
	$result;
}

1;

__END__