File Coverage

blib/lib/Math/Roman.pm

Criterion	Covered	Total	%
statement	97	116	83.6
branch	33	46	71.7
condition	6	9	66.6
subroutine	12	14	85.7
pod	6	6	100.0
total	154	191	80.6

# -*- mode: perl; -*-

# todo: could be faster,storing values of tokes as Math::BigInt instead integer
#       makes it slower (due to $k < $last)
#       Roman.pm uses 4.2s for 1...4000 compared to our 6.5s (new())
#       and 5.7s (roman()), so actually we are pretty fast (we construct a
#       bigint on-the-fly, too!)
#
#       maybe: make 'use Roman qw(badd); print badd("M","X"),"\n";' work:
# just define the following and allow of export badd:
# sub badd
#   {
#   if ($_[0] eq $class)
#     {
#     shift;
#     }
#   $class->SUPER::badd(@_);
#   }
# The problem is the additional overhead (about 2%) and the problem to write
# the above for _all_ functions of Math::BigInt. That's rather long. AUTOLOAD does
# not work, since it steps in _after_ inheritance. Do we really need this?
# 2001-11-08: Don't think we need it, othe subclasses don't do it, either. Tels

package Math::Roman;

use strict;
use warnings;
use Math::BigInt;

require 5.006;          # requires this Perl version or later
require Exporter;

our ($VERSION, @ISA, @EXPORT_OK);

$VERSION   = '1.10';    # current version of this package
@ISA       = qw(Exporter Math::BigInt);
@EXPORT_OK = qw( as_number tokens roman error );

use overload;           # inherit from MBI

#############################################################################
# global variables

my $sh;       # hash of roman symbols (symbol => value)
my $sm;       # hash of roman symbols (value  => symbol)
my $ss;       # a list sorted by value
my $re;       # compiled regexps matching tokens
my $err;      # error message
my $bt;       # biggest token
my $bv;       # biggest value

# roman() is an exportable version of new()
sub roman {
    my $class = __PACKAGE__;
    return $class -> new(shift);
}

sub error {
    # return last error message in case of NaN
    return $err;
}

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;

    my $value = shift;
    $value = 0 if !defined $value;

    # Try construct a number (if we got '1999').
    #
    # After Math::BigInt started supporting hexadecimal numbers with just the
    # "X" prefix, like CORE::hex(), the value can no longer be fed directly to
    # Math::BigInt->new(). For instance, Math::BigInt->new("X") used to return a
    # "NaN", now it returns 0, just like CORE::hex("X").

    my $self;
    if ($value =~ /[IVXLCDM]/) {
        $self = Math::Roman -> bzero();
        $self -> _initialize($value);
    } elsif (length $value) {
        $self = Math::BigInt -> new($value);
    } else {
        $self = Math::BigInt -> bzero();
    }

    bless $self, $class;            # rebless
}

#############################################################################
# self initalization

sub tokens
  {
  # set/return list of valid/invalid tokens
  # sorted by length to favour 'IM' over 'I' when matching
  # create hash and length sorted array
  my @sym = @_;
  # return current token set
  return map { $_, $sh->{$_} } keys %$sh if (@_ == 0);
  my $sl = []; # a list sorted by name-length
  $ss = [];
  $sh = {}; $sm = {};
  $bv = -1; $bt = ''; $re = "";
  my $i;
  for ($i = 0; $i<@sym;$i += 2)
    {
    #print "token $sym[$i] => $sym[$i+1]\n";
    push @$sl,$sym[$i];                # store all tokens in a tmp list
    $sh->{$sym[$i]} = int($sym[$i+1]); # contain all token=>value
    if (int($sym[$i+1]) != -1)         # only valid ones
      {
      push @$ss,int($sym[$i+1]);       # for regexp compiler
      $sm->{$sym[$i+1]} = $sym[$i];    # generate hash for value=>token
      ($bt,$bv) = ($sym[$i],int($sym[$i+1])) if (int($sym[$i+1]) > $bv);
      }
    }
  # sort symbols by name length (and if equal, by value)
  @$sl = sort { length $b <=> length $a || $sh->{$b} <=> $sh->{$a} } @$sl;
  # compile a big regexp for token parsing
  $re = join('|', @$sl);
  # print "regexp '$re'\n";
  # for converting Arabic => Roman
  @$ss = sort { $b <=> $a } @$ss;
  # return current token set
  return map { $_, $sh->{$_} } keys %$sh if (@_ == 0);
  }

BEGIN
  {
  tokens( qw(
        IIII            -1
        XXXX            -1
        CCCC            -1
        DD              -1
        LL              -1
        VV              -1
        C[MD][CDM]      -1
        X[LC][XLCDM]    -1
        I[VX][IVXLCDM]  -1
        LXL             -1
        III     3
        XXX     30
        CCC     300
        II      2
        XX      20
        CC      200
        IV      4
        IX      9
        XL      40
        XC      90
        CD      400
        CM      900
        I       1
        V       5
        X       10
        L       50
        C       100
        D       500
        M       1000
  ) );
  undef $err;
  }

  # check for illegal sequences (simple return, we are already NaN)
  # the following are not valid tokens according to rules:
  # IIII
  # XXXX
  # CCCC
  # only ICX as precede:
  # VX  5
  # VL  45
  # VC  95
  # VD  495
  # LM  995
  # LC  50
  # LD  450
  # LM  950
  # not smaller then 10 preceding:
  # IL  49
  # IC  99
  # ID  499
  # IM  999
  # XD  490
  # XM  990
  # illegal ones, smaller then following (several cases are already caught
  # by rule: token0 < token1)
  # CDD (C < D)
  # CDC (C = C)
  # XCD (X < D)
  # LXL (L = L)
  # They need to be checked separetely, the following regexps take care
  # of that:
  # C[MD][CDM]
  # X[LC][XLCDM]
  # I[VX][IVXLCDM]

sub _initialize
  {
  # set yourself to the value represented by the given string
  my $self = shift;
  my $value = shift;

  $self->bzero(); # start with 0

  # this is probably very inefficient...
  my $e = 0; my $last = -1; undef $err;
  while ((length($value) > 0) && ($e == 0))
    {
    # can't use /o since tokens might redefine $re
    $value =~ s/^($re)//;
    if (defined $1)
      {
      _symb($self,$1,\$e,\$last);
      }
    else
      {
      $err = "Math::Roman: Invalid part '$value' encountered.";
      $e = 4;
      }
    }
  $self->bnan() if ($e != 0);
  return;
  }

sub _symb
  {
  # current symbol, last symbole, error
  my ($self,$s,$error,$last) = @_;
  #print "$s => ";
  my $k = $sh->{$s}; # get value of token
  #print "$k" if defined $k;
  if (!defined $k)
    {
    $err = "Math::Roman: Undefined token '$s' encountered.";
    $$error = 1;
    }
  else
    {
    if ($k == -1)
      {
      $err = "Math::Roman: Invalid token '$s' encountered.";
      $$error = 2;
      }
    $$last = $k if $$last == -1;
    # next symbol must always be smaller then previous
    if ($k > $$last)
      {
      $err = "Math::Roman: Token '$s' ($k) is greater than last ('$$last').";
      $$error = 3;
      }
    }
  return if $$error != 0;
  $self->badd($k); $$last = $k;
  return;
  }

sub bstr
  {
  my ($x) = @_;
  return $x if !ref($x);
  return '' if $x->is_zero();
  return 'NaN' if $x->is_nan;

  # make sure that we calculate with Math::BigInt objects, otherwise objectify()
  # will try to make copies of us via bstr(), resulting in deep recursion
  my $rem = $x->as_number(); $rem->babs();
  ## get the biggest symbol
  #return $bt if $rem == $bv;

  my $es = ''; my $cnt;
  my $level = -1; # for all tokens
  while (($level < scalar @$ss) && (!$rem->is_zero()))
    {
    $level++;
    next if $ss->[$level] > $rem;               # this wont fit
    # calculate number of biggest token
    ($cnt,$rem) = $rem->bdiv($ss->[$level]);
    if ($rem->sign() eq 'NaN')
      {
      warn ("Something went wrong at token $ss->[$level].");
      return 'NaN';
      }
    # this limits $cnt to be < 65536, anyway 65536 Ms is impressive though)
    $cnt = int ($cnt);
    $es .= $sm->{$ss->[$level]} x $cnt if $cnt != 0;
    }
  return $es;
  # remove biggest token(s) so that only reminder is left
  #my $es = '';
  #my $cnt;
  #if ($rem > $bv)
  #  {
  #  # calculate number of biggest token
  #  ($cnt,$rem) = $rem->bdiv($bv);
  #  if ($rem->sign() eq 'NaN')
  #    {
  #    warn ("Something went wrong with bt='$bt' and bv='$bv'");
  ##    return 'NaN';
  #    }
  #  # this limits $cnt to be < 65536, anyway 65536 Ms is impressive though)
  #  $es = $bt x $cnt;
  #  }
  #return $es if $rem->is_zero();
  # find combination of tokens (with decreasing value) that matches reminder
  # restricted knappsack problem with symbols in @sym, sum 1...999
  #my $stack = []; my $value = 0;
  #_recurse(0,\$value,$stack,int($rem));
  #print "done $value $rem\n";
  # found valid combination? (should never fail if system is consistent!)
  #if ($value == $rem)
  #  {
  #  map { $es .= $_ } @$stack;
  #  # {
  #  # $es .= $_;
  ##  # }
  #  # $es .= join //,@$stack; # faster but gives error!?
  #  return $es;
  #  }
  #return 'NaN';
  }

sub _recurse
  {
  my ($level,$value,$stack,$rem) = @_;
  #print "level $level cur $$value target $rem ",scalar @$ss,"\n";

  return if $$value >= $rem;                 # early out, can not get smaller
  while ($level < scalar @$ss)
    {
    # get current value according to level
    my $s = $ss->[$level];
    # and try it
    push @$stack,$sm->{$s};                  # get symbol from value
    #print " "x$level."Trying $s $sm->{$s} at level $level\n";
    $$value += $s;                           # add to test value
    _recurse($level,$value,$stack,$rem);     # try to add more symbols
    #print " "x$level."back w/ $$value $rem\n";
    last if $$value == $rem;                 # keep this try
    $$value -= $s;                           # reverse try
    pop @$stack;
    $level ++;
    }
  return;
  }

sub as_number
  {
  my $self = shift;

  Math::BigInt->new($self->SUPER::bstr());
  }

1;

__END__