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


line stmt bran cond sub pod time code
1             # -*- mode: perl; -*-
2              
3             # todo: could be faster,storing values of tokes as Math::BigInt instead integer
4             # makes it slower (due to $k < $last)
5             # Roman.pm uses 4.2s for 1...4000 compared to our 6.5s (new())
6             # and 5.7s (roman()), so actually we are pretty fast (we construct a
7             # bigint on-the-fly, too!)
8             #
9             # maybe: make 'use Roman qw(badd); print badd("M","X"),"\n";' work:
10             # just define the following and allow of export badd:
11             # sub badd
12             # {
13             # if ($_[0] eq $class)
14             # {
15             # shift;
16             # }
17             # $class->SUPER::badd(@_);
18             # }
19             # The problem is the additional overhead (about 2%) and the problem to write
20             # the above for _all_ functions of Math::BigInt. That's rather long. AUTOLOAD does
21             # not work, since it steps in _after_ inheritance. Do we really need this?
22             # 2001-11-08: Don't think we need it, othe subclasses don't do it, either. Tels
23              
24             package Math::Roman;
25              
26 2     2   132876 use strict;
  2         18  
  2         57  
27 2     2   10 use warnings;
  2         4  
  2         55  
28 2     2   2408 use Math::BigInt;
  2         56542  
  2         9  
29              
30             require 5.006; # requires this Perl version or later
31             require Exporter;
32              
33             our ($VERSION, @ISA, @EXPORT_OK);
34              
35             $VERSION = '1.10'; # current version of this package
36             @ISA = qw(Exporter Math::BigInt);
37             @EXPORT_OK = qw( as_number tokens roman error );
38              
39 2     2   46143 use overload; # inherit from MBI
  2         5  
  2         11  
40              
41             #############################################################################
42             # global variables
43              
44             my $sh; # hash of roman symbols (symbol => value)
45             my $sm; # hash of roman symbols (value => symbol)
46             my $ss; # a list sorted by value
47             my $re; # compiled regexps matching tokens
48             my $err; # error message
49             my $bt; # biggest token
50             my $bv; # biggest value
51              
52             # roman() is an exportable version of new()
53             sub roman {
54 2     2 1 384 my $class = __PACKAGE__;
55 2         7 return $class -> new(shift);
56             }
57              
58             sub error {
59             # return last error message in case of NaN
60 0     0 1 0 return $err;
61             }
62              
63             sub new {
64 5785     5785 1 917340 my $proto = shift;
65 5785   33     17795 my $class = ref($proto) || $proto;
66              
67 5785         8123 my $value = shift;
68 5785 50       10816 $value = 0 if !defined $value;
69              
70             # Try construct a number (if we got '1999').
71             #
72             # After Math::BigInt started supporting hexadecimal numbers with just the
73             # "X" prefix, like CORE::hex(), the value can no longer be fed directly to
74             # Math::BigInt->new(). For instance, Math::BigInt->new("X") used to return a
75             # "NaN", now it returns 0, just like CORE::hex("X").
76              
77 5785         7238 my $self;
78 5785 100       17862 if ($value =~ /[IVXLCDM]/) {
    100          
79 1064         2722 $self = Math::Roman -> bzero();
80 1064         22423 $self -> _initialize($value);
81             } elsif (length $value) {
82 4720         12828 $self = Math::BigInt -> new($value);
83             } else {
84 1         8 $self = Math::BigInt -> bzero();
85             }
86              
87 5785         197617 bless $self, $class; # rebless
88             }
89              
90             #############################################################################
91             # self initalization
92              
93             sub tokens
94             {
95             # set/return list of valid/invalid tokens
96             # sorted by length to favour 'IM' over 'I' when matching
97             # create hash and length sorted array
98 3     3 1 1726 my @sym = @_;
99             # return current token set
100 3 50       15 return map { $_, $sh->{$_} } keys %$sh if (@_ == 0);
  0         0  
101 3         8 my $sl = []; # a list sorted by name-length
102 3         12 $ss = [];
103 3         18 $sh = {}; $sm = {};
  3         12  
104 3         14 $bv = -1; $bt = ''; $re = "";
  3         12  
  3         6  
105 3         5 my $i;
106 3         20 for ($i = 0; $i<@sym;$i += 2)
107             {
108             #print "token $sym[$i] => $sym[$i+1]\n";
109 65         121 push @$sl,$sym[$i]; # store all tokens in a tmp list
110 65         165 $sh->{$sym[$i]} = int($sym[$i+1]); # contain all token=>value
111 65 100       120 if (int($sym[$i+1]) != -1) # only valid ones
112             {
113 45         69 push @$ss,int($sym[$i+1]); # for regexp compiler
114 45         89 $sm->{$sym[$i+1]} = $sym[$i]; # generate hash for value=>token
115 45 100       108 ($bt,$bv) = ($sym[$i],int($sym[$i+1])) if (int($sym[$i+1]) > $bv);
116             }
117             }
118             # sort symbols by name length (and if equal, by value)
119 3 50       33 @$sl = sort { length $b <=> length $a || $sh->{$b} <=> $sh->{$a} } @$sl;
  197         350  
120             # compile a big regexp for token parsing
121 3         16 $re = join('|', @$sl);
122             # print "regexp '$re'\n";
123             # for converting Arabic => Roman
124 3         19 @$ss = sort { $b <=> $a } @$ss;
  121         149  
125             # return current token set
126 3 50       42 return map { $_, $sh->{$_} } keys %$sh if (@_ == 0);
  0         0  
127             }
128              
129             BEGIN
130             {
131 2     2   1075 tokens( qw(
132             IIII -1
133             XXXX -1
134             CCCC -1
135             DD -1
136             LL -1
137             VV -1
138             C[MD][CDM] -1
139             X[LC][XLCDM] -1
140             I[VX][IVXLCDM] -1
141             LXL -1
142             III 3
143             XXX 30
144             CCC 300
145             II 2
146             XX 20
147             CC 200
148             IV 4
149             IX 9
150             XL 40
151             XC 90
152             CD 400
153             CM 900
154             I 1
155             V 5
156             X 10
157             L 50
158             C 100
159             D 500
160             M 1000
161             ) );
162 2         1416 undef $err;
163             }
164              
165             # check for illegal sequences (simple return, we are already NaN)
166             # the following are not valid tokens according to rules:
167             # IIII
168             # XXXX
169             # CCCC
170             # only ICX as precede:
171             # VX 5
172             # VL 45
173             # VC 95
174             # VD 495
175             # LM 995
176             # LC 50
177             # LD 450
178             # LM 950
179             # not smaller then 10 preceding:
180             # IL 49
181             # IC 99
182             # ID 499
183             # IM 999
184             # XD 490
185             # XM 990
186             # illegal ones, smaller then following (several cases are already caught
187             # by rule: token0 < token1)
188             # CDD (C < D)
189             # CDC (C = C)
190             # XCD (X < D)
191             # LXL (L = L)
192             # They need to be checked separetely, the following regexps take care
193             # of that:
194             # C[MD][CDM]
195             # X[LC][XLCDM]
196             # I[VX][IVXLCDM]
197              
198             sub _initialize
199             {
200             # set yourself to the value represented by the given string
201 1064     1064   1594 my $self = shift;
202 1064         1663 my $value = shift;
203              
204 1064         2423 $self->bzero(); # start with 0
205              
206             # this is probably very inefficient...
207 1064         18888 my $e = 0; my $last = -1; undef $err;
  1064         1697  
  1064         1641  
208 1064   100     3716 while ((length($value) > 0) && ($e == 0))
209             {
210             # can't use /o since tokens might redefine $re
211 3714         22122 $value =~ s/^($re)//;
212 3714 50       9009 if (defined $1)
213             {
214 3714         7944 _symb($self,$1,\$e,\$last);
215             }
216             else
217             {
218 0         0 $err = "Math::Roman: Invalid part '$value' encountered.";
219 0         0 $e = 4;
220             }
221             }
222 1064 100       2016 $self->bnan() if ($e != 0);
223 1064         2105 return;
224             }
225              
226             sub _symb
227             {
228             # current symbol, last symbole, error
229 3714     3714   10652 my ($self,$s,$error,$last) = @_;
230             #print "$s => ";
231 3714         7523 my $k = $sh->{$s}; # get value of token
232             #print "$k" if defined $k;
233 3714 100       6334 if (!defined $k)
234             {
235 5         11 $err = "Math::Roman: Undefined token '$s' encountered.";
236 5         10 $$error = 1;
237             }
238             else
239             {
240 3709 100       6623 if ($k == -1)
241             {
242 7         20 $err = "Math::Roman: Invalid token '$s' encountered.";
243 7         10 $$error = 2;
244             }
245 3709 100       6814 $$last = $k if $$last == -1;
246             # next symbol must always be smaller then previous
247 3709 100       6493 if ($k > $$last)
248             {
249 17         92 $err = "Math::Roman: Token '$s' ($k) is greater than last ('$$last').";
250 17         26 $$error = 3;
251             }
252             }
253 3714 100       6345 return if $$error != 0;
254 3685         9265 $self->badd($k); $$last = $k;
  3685         217966  
255 3685         15194 return;
256             }
257              
258             sub bstr
259             {
260 1033     1033 1 9312 my ($x) = @_;
261 1033 50       2850 return $x if !ref($x);
262 1033 100       2558 return '' if $x->is_zero();
263 1032 50       15549 return 'NaN' if $x->is_nan;
264              
265             # make sure that we calculate with Math::BigInt objects, otherwise objectify()
266             # will try to make copies of us via bstr(), resulting in deep recursion
267 1032         6407 my $rem = $x->as_number(); $rem->babs();
  1032         55480  
268             ## get the biggest symbol
269             #return $bt if $rem == $bv;
270              
271 1032         8467 my $es = ''; my $cnt;
  1032         1259  
272 1032         1384 my $level = -1; # for all tokens
273 1032   66     3115 while (($level < scalar @$ss) && (!$rem->is_zero()))
274             {
275 16699         1513268 $level++;
276 16699 100       34673 next if $ss->[$level] > $rem; # this wont fit
277             # calculate number of biggest token
278 3652         232332 ($cnt,$rem) = $rem->bdiv($ss->[$level]);
279 3652 50       810722 if ($rem->sign() eq 'NaN')
280             {
281 0         0 warn ("Something went wrong at token $ss->[$level].");
282 0         0 return 'NaN';
283             }
284             # this limits $cnt to be < 65536, anyway 65536 Ms is impressive though)
285 3652         25584 $cnt = int ($cnt);
286 3652 50       165045 $es .= $sm->{$ss->[$level]} x $cnt if $cnt != 0;
287             }
288 1032         204425 return $es;
289             # remove biggest token(s) so that only reminder is left
290             #my $es = '';
291             #my $cnt;
292             #if ($rem > $bv)
293             # {
294             # # calculate number of biggest token
295             # ($cnt,$rem) = $rem->bdiv($bv);
296             # if ($rem->sign() eq 'NaN')
297             # {
298             # warn ("Something went wrong with bt='$bt' and bv='$bv'");
299             ## return 'NaN';
300             # }
301             # # this limits $cnt to be < 65536, anyway 65536 Ms is impressive though)
302             # $es = $bt x $cnt;
303             # }
304             #return $es if $rem->is_zero();
305             # find combination of tokens (with decreasing value) that matches reminder
306             # restricted knappsack problem with symbols in @sym, sum 1...999
307             #my $stack = []; my $value = 0;
308             #_recurse(0,\$value,$stack,int($rem));
309             #print "done $value $rem\n";
310             # found valid combination? (should never fail if system is consistent!)
311             #if ($value == $rem)
312             # {
313             # map { $es .= $_ } @$stack;
314             # # {
315             # # $es .= $_;
316             ## # }
317             # # $es .= join //,@$stack; # faster but gives error!?
318             # return $es;
319             # }
320             #return 'NaN';
321             }
322              
323             sub _recurse
324             {
325 0     0   0 my ($level,$value,$stack,$rem) = @_;
326             #print "level $level cur $$value target $rem ",scalar @$ss,"\n";
327              
328 0 0       0 return if $$value >= $rem; # early out, can not get smaller
329 0         0 while ($level < scalar @$ss)
330             {
331             # get current value according to level
332 0         0 my $s = $ss->[$level];
333             # and try it
334 0         0 push @$stack,$sm->{$s}; # get symbol from value
335             #print " "x$level."Trying $s $sm->{$s} at level $level\n";
336 0         0 $$value += $s; # add to test value
337 0         0 _recurse($level,$value,$stack,$rem); # try to add more symbols
338             #print " "x$level."back w/ $$value $rem\n";
339 0 0       0 last if $$value == $rem; # keep this try
340 0         0 $$value -= $s; # reverse try
341 0         0 pop @$stack;
342 0         0 $level ++;
343             }
344 0         0 return;
345             }
346              
347             sub as_number
348             {
349 2095     2095 1 3497 my $self = shift;
350              
351 2095         5630 Math::BigInt->new($self->SUPER::bstr());
352             }
353              
354             1;
355              
356             __END__