|
996
|
1 package Language::INTERCAL::ReadNumbers;
|
|
|
2
|
|
|
3 # Convert numbers to Roman numerals
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/ReadNumbers.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19 use Language::INTERCAL::Splats '1.-94.-2', qw(SP_ROMAN faint);
|
|
|
20 use vars qw(@EXPORT @EXPORT_OK);
|
|
|
21 @EXPORT = ();
|
|
|
22 @EXPORT_OK = qw(roman_type roman_name roman_type_default read_number roman);
|
|
|
23
|
|
|
24 my (@roman_types, %roman_types);
|
|
|
25
|
|
|
26 BEGIN {
|
|
|
27 @roman_types = (
|
|
|
28 ['CLC' => \&_roman_clc], # CLC-INTERCAL's "roman"
|
|
|
29 ['UNDERLINE' => \&_roman_underline], # alternative CLC-INTERCAL's
|
|
|
30 ['ARCHAIC' => \&_roman_archaic], # as used when Rome was new
|
|
|
31 ['MEDIAEVAL' => \&_roman_mediaeval], # as used in the middle ages
|
|
|
32 ['MODERN' => \&_roman_modern], # as used today
|
|
|
33 ['TRADITIONAL' => \&_roman_1972], # INTERCAL-1972
|
|
|
34 ['WIMPMODE' => \&_roman_wimpmode], # not Roman at all
|
|
|
35 );
|
|
|
36
|
|
|
37 %roman_types =
|
|
|
38 map { ( $roman_types[$_][0] => $_ + 1 ) } (0..@roman_types - 1);
|
|
|
39
|
|
|
40 my $d = $roman_types{'CLC'};
|
|
|
41 use vars '*roman_type_default';
|
|
|
42 *roman_type_default = sub () { $d };
|
|
|
43 }
|
|
|
44
|
|
|
45 sub roman_type {
|
|
|
46 @_ == 1 or croak "Usage: roman_type(TYPE)";
|
|
|
47 my ($type) = @_;
|
|
|
48 $type =~ s/\s+//g;
|
|
|
49 if ($type =~ /^\d+$/) {
|
|
|
50 return roman_type_default if $type == 0;
|
|
|
51 return $type < 1 || $type > @roman_types ? undef : $type;
|
|
|
52 } else {
|
|
|
53 return exists $roman_types{$type} ? $roman_types{$type} : undef;
|
|
|
54 }
|
|
|
55 }
|
|
|
56
|
|
|
57 sub roman_name {
|
|
|
58 @_ == 1 or croak "Usage: roman_name(TYPE)";
|
|
|
59 my ($type) = @_;
|
|
|
60 $type = roman_type_default if $type == 0;
|
|
|
61 return undef if $type < 1 || $type > @roman_types;
|
|
|
62 return $roman_types[$type - 1][0];
|
|
|
63 }
|
|
|
64
|
|
|
65 sub read_number {
|
|
|
66 @_ == 3 or croak "Usage: read_number(NUMBER, TYPE, FILEHANDLE)";
|
|
|
67 my ($number, $type, $fh) = @_;
|
|
|
68 my $rtype = roman_type($type);
|
|
|
69 defined $rtype or faint(SP_ROMAN, $type);
|
|
|
70 for my $line (&{$roman_types[$rtype - 1][1]}($number)) {
|
|
|
71 $fh->read_text($line . "\n");
|
|
|
72 }
|
|
|
73 }
|
|
|
74
|
|
|
75 sub roman {
|
|
|
76 @_ == 2 or croak "Usage: read_number(NUMBER, TYPE)";
|
|
|
77 my ($number, $type, $fh) = @_;
|
|
|
78 my $rtype = roman_type($type);
|
|
|
79 defined $rtype or faint(SP_ROMAN, $type);
|
|
|
80 return &{$roman_types[$rtype - 1][1]}($number);
|
|
|
81 }
|
|
|
82
|
|
|
83 sub _roman_clc {
|
|
|
84 my ($number) = @_;
|
|
|
85 if ($number == 0) {
|
|
|
86 return "NIHIL";
|
|
|
87 }
|
|
|
88 my $result = '';
|
|
|
89 if ($number >= 4000000000) {
|
|
|
90 my $val = lc(_numeral(int($number / 1000000000)));
|
|
|
91 $val =~ s/(.)/\\$1/g;
|
|
|
92 $result .= $val;
|
|
|
93 $number %= 1000000000;
|
|
|
94 }
|
|
|
95 if ($number >= 4000000) {
|
|
|
96 my $val = uc(_numeral(int($number / 1000000)));
|
|
|
97 $val =~ s/(.)/\\$1/g;
|
|
|
98 $result .= $val;
|
|
|
99 $number %= 1000000;
|
|
|
100 }
|
|
|
101 if ($number >= 4000) {
|
|
|
102 $result .= lc(_numeral(int($number / 1000)));
|
|
|
103 $number %= 1000;
|
|
|
104 }
|
|
|
105 if ($number > 0) {
|
|
|
106 $result .= uc(_numeral($number));
|
|
|
107 }
|
|
|
108 $result;
|
|
|
109 }
|
|
|
110
|
|
|
111 sub _roman_underline {
|
|
|
112 my ($number) = @_;
|
|
|
113 if ($number == 0) {
|
|
|
114 return "NIHIL";
|
|
|
115 }
|
|
|
116 my $result = '';
|
|
|
117 if ($number >= 4000000000) {
|
|
|
118 my $val = lc(_numeral(int($number / 1000000000)));
|
|
|
119 $val =~ s/(.)/_\b$1/g;
|
|
|
120 $result .= $val;
|
|
|
121 $number %= 1000000000;
|
|
|
122 }
|
|
|
123 if ($number >= 4000000) {
|
|
|
124 my $val = uc(_numeral(int($number / 1000000)));
|
|
|
125 $val =~ s/(.)/_\b$1/g;
|
|
|
126 $result .= $val;
|
|
|
127 $number %= 1000000;
|
|
|
128 }
|
|
|
129 if ($number >= 4000) {
|
|
|
130 $result .= lc(_numeral(int($number / 1000)));
|
|
|
131 $number %= 1000;
|
|
|
132 }
|
|
|
133 if ($number > 0) {
|
|
|
134 $result .= uc(_numeral($number));
|
|
|
135 }
|
|
|
136 $result;
|
|
|
137 }
|
|
|
138
|
|
|
139 sub _roman_mediaeval {
|
|
|
140 my ($number) = @_;
|
|
|
141 if ($number == 0) {
|
|
|
142 return "NIHIL";
|
|
|
143 }
|
|
|
144 my $first = '';
|
|
|
145 my $second = '';
|
|
|
146 if ($number >= 500000000) {
|
|
|
147 my $val = uc(_m_numeral(int($number / 500000000) * 5));
|
|
|
148 $first .= ' _ ' x length($val);
|
|
|
149 $val =~ s/(.)/||$1||/g;
|
|
|
150 $second .= $val;
|
|
|
151 $number %= 500000000;
|
|
|
152 }
|
|
|
153 if ($number >= 5000000) {
|
|
|
154 my $val = uc(_m_numeral(int($number / 5000000) * 5));
|
|
|
155 $first .= ' _ ' x length($val);
|
|
|
156 $val =~ s/(.)/|$1|/g;
|
|
|
157 $second .= $val;
|
|
|
158 $number %= 5000000;
|
|
|
159 }
|
|
|
160 if ($number >= 5000) {
|
|
|
161 my $val = uc(_m_numeral(int($number / 5000) * 5));
|
|
|
162 $first .= '_' x length($val);
|
|
|
163 $second .= $val;
|
|
|
164 $number %= 5000;
|
|
|
165 }
|
|
|
166 if ($number > 0) {
|
|
|
167 my $val = uc(_m_numeral($number));
|
|
|
168 $first .= ' ' x length($val);
|
|
|
169 $second .= $val;
|
|
|
170 }
|
|
|
171 $first =~ s/\s+$//;
|
|
|
172 $first ne '' ? ($first, $second) : ($second);
|
|
|
173 }
|
|
|
174
|
|
|
175 sub _roman_modern {
|
|
|
176 my ($number) = @_;
|
|
|
177 if ($number == 0) {
|
|
|
178 return "NIHIL";
|
|
|
179 }
|
|
|
180 my $first = '';
|
|
|
181 my $second = '';
|
|
|
182 if ($number >= 100000000) {
|
|
|
183 my $val = uc(_numeral(int($number / 100000000) * 10));
|
|
|
184 $first .= ' _ ' x length($val);
|
|
|
185 $val =~ s/(.)/||$1||/g;
|
|
|
186 $second .= $val;
|
|
|
187 $number %= 100000000;
|
|
|
188 }
|
|
|
189 if ($number >= 1000000) {
|
|
|
190 my $val = uc(_numeral(int($number / 1000000) * 10));
|
|
|
191 $first .= ' _ ' x length($val);
|
|
|
192 $val =~ s/(.)/|$1|/g;
|
|
|
193 $second .= $val;
|
|
|
194 $number %= 1000000;
|
|
|
195 }
|
|
|
196 if ($number >= 1000) {
|
|
|
197 my $val = uc(_numeral(int($number / 1000)));
|
|
|
198 $first .= '_' x length($val);
|
|
|
199 $second .= $val;
|
|
|
200 $number %= 1000;
|
|
|
201 }
|
|
|
202 if ($number > 0) {
|
|
|
203 my $val = uc(_numeral($number));
|
|
|
204 $first .= ' ' x length($val);
|
|
|
205 $second .= $val;
|
|
|
206 }
|
|
|
207 $first =~ s/\s+$//;
|
|
|
208 $first ne '' ? ($first, $second) : ($second);
|
|
|
209 }
|
|
|
210
|
|
|
211 sub _roman_wimpmode {
|
|
|
212 my ($number) = @_;
|
|
|
213 $number + 0;
|
|
|
214 }
|
|
|
215
|
|
|
216 sub _roman_archaic {
|
|
|
217 my ($number) = @_;
|
|
|
218 if ($number == 0) {
|
|
|
219 return "NIHIL";
|
|
|
220 }
|
|
|
221 my $result = '';
|
|
|
222 if ($number >= 1000000000) {
|
|
|
223 $result .= _a_numeral(7, int($number / 1000000000));
|
|
|
224 $number %= 1000000000;
|
|
|
225 }
|
|
|
226 if ($number >= 100000000) {
|
|
|
227 $result .= _a_numeral(6, int($number / 100000000));
|
|
|
228 $number %= 100000000;
|
|
|
229 }
|
|
|
230 if ($number >= 10000000) {
|
|
|
231 $result .= _a_numeral(5, int($number / 10000000));
|
|
|
232 $number %= 10000000;
|
|
|
233 }
|
|
|
234 if ($number >= 1000000) {
|
|
|
235 $result .= _a_numeral(4, int($number / 1000000));
|
|
|
236 $number %= 1000000;
|
|
|
237 }
|
|
|
238 if ($number >= 100000) {
|
|
|
239 $result .= _a_numeral(3, int($number / 100000));
|
|
|
240 $number %= 100000;
|
|
|
241 }
|
|
|
242 if ($number >= 10000) {
|
|
|
243 $result .= _a_numeral(2, int($number / 10000));
|
|
|
244 $number %= 10000;
|
|
|
245 }
|
|
|
246 if ($number >= 1000) {
|
|
|
247 $result .= _a_numeral(1, int($number / 1000));
|
|
|
248 $number %= 1000;
|
|
|
249 }
|
|
|
250 if ($number >= 500) {
|
|
|
251 $result .= 'I)';
|
|
|
252 $number -= 500;
|
|
|
253 }
|
|
|
254 if ($number >= 1) {
|
|
|
255 $result .= uc(_m_numeral($number));
|
|
|
256 }
|
|
|
257 $result;
|
|
|
258 }
|
|
|
259
|
|
|
260 sub _roman_1972 {
|
|
|
261 my ($number) = @_;
|
|
|
262 if ($number == 0) {
|
|
|
263 return "_", " ";
|
|
|
264 }
|
|
|
265 my $first = '';
|
|
|
266 my $second = '';
|
|
|
267 if ($number >= 4000000000) {
|
|
|
268 my $val = lc(_numeral(int($number / 1000000000)));
|
|
|
269 $first .= '_' x length($val);
|
|
|
270 $second .= $val;
|
|
|
271 $number %= 1000000000;
|
|
|
272 }
|
|
|
273 if ($number >= 4000000) {
|
|
|
274 my $val = lc(_numeral(int($number / 1000000)));
|
|
|
275 $first .= ' ' x length($val);
|
|
|
276 $second .= $val;
|
|
|
277 $number %= 1000000;
|
|
|
278 }
|
|
|
279 if ($number >= 4000) {
|
|
|
280 my $val = uc(_numeral(int($number / 1000)));
|
|
|
281 $first .= '_' x length($val);
|
|
|
282 $second .= $val;
|
|
|
283 $number %= 1000;
|
|
|
284 }
|
|
|
285 if ($number > 0) {
|
|
|
286 my $val = uc(_numeral($number));
|
|
|
287 $first .= ' ' x length($val);
|
|
|
288 $second .= $val;
|
|
|
289 }
|
|
|
290 $first =~ s/\s+$//;
|
|
|
291 ($first, $second);
|
|
|
292 }
|
|
|
293
|
|
|
294 sub _numeral {
|
|
|
295 my ($value) = @_;
|
|
|
296 my $result = '';
|
|
|
297 if ($value >= 1000) {
|
|
|
298 $result .= 'M' x int($value / 1000);
|
|
|
299 $value %= 1000;
|
|
|
300 }
|
|
|
301 if ($value >= 900) {
|
|
|
302 $result .= 'CM';
|
|
|
303 $value -= 900;
|
|
|
304 }
|
|
|
305 if ($value >= 500) {
|
|
|
306 $result .= 'D';
|
|
|
307 $value -= 500;
|
|
|
308 }
|
|
|
309 if ($value >= 400) {
|
|
|
310 $result .= 'CD';
|
|
|
311 $value -= 400;
|
|
|
312 }
|
|
|
313 if ($value >= 100) {
|
|
|
314 $result .= 'C' x int($value / 100);
|
|
|
315 $value %= 100;
|
|
|
316 }
|
|
|
317 if ($value >= 90) {
|
|
|
318 $result .= 'XC';
|
|
|
319 $value -= 90;
|
|
|
320 }
|
|
|
321 if ($value >= 50) {
|
|
|
322 $result .= 'L';
|
|
|
323 $value -= 50;
|
|
|
324 }
|
|
|
325 if ($value >= 40) {
|
|
|
326 $result .= 'XL';
|
|
|
327 $value -= 40;
|
|
|
328 }
|
|
|
329 if ($value >= 10) {
|
|
|
330 $result .= 'X' x int($value / 10);
|
|
|
331 $value %= 10;
|
|
|
332 }
|
|
|
333 if ($value >= 9) {
|
|
|
334 $result .= 'IX';
|
|
|
335 $value -= 9;
|
|
|
336 }
|
|
|
337 if ($value >= 5) {
|
|
|
338 $result .= 'V';
|
|
|
339 $value -= 5;
|
|
|
340 }
|
|
|
341 if ($value >= 4) {
|
|
|
342 $result .= 'IV';
|
|
|
343 $value -= 4;
|
|
|
344 }
|
|
|
345 if ($value >= 1) {
|
|
|
346 $result .= 'I' x $value;
|
|
|
347 $value %= 1;
|
|
|
348 }
|
|
|
349 $result;
|
|
|
350 }
|
|
|
351
|
|
|
352 sub _m_numeral {
|
|
|
353 my ($value) = @_;
|
|
|
354 my $result = '';
|
|
|
355 if ($value >= 1000) {
|
|
|
356 $result .= 'M' x int($value / 1000);
|
|
|
357 $value %= 1000;
|
|
|
358 }
|
|
|
359 if ($value >= 500) {
|
|
|
360 $result .= 'D';
|
|
|
361 $value -= 500;
|
|
|
362 }
|
|
|
363 if ($value >= 100) {
|
|
|
364 $result .= 'C' x int($value / 100);
|
|
|
365 $value %= 100;
|
|
|
366 }
|
|
|
367 if ($value >= 50) {
|
|
|
368 $result .= 'L';
|
|
|
369 $value -= 50;
|
|
|
370 }
|
|
|
371 if ($value >= 10) {
|
|
|
372 $result .= 'X' x int($value / 10);
|
|
|
373 $value %= 10;
|
|
|
374 }
|
|
|
375 if ($value >= 5) {
|
|
|
376 $result .= 'V';
|
|
|
377 $value -= 5;
|
|
|
378 }
|
|
|
379 if ($value >= 1) {
|
|
|
380 $result .= 'I' x $value;
|
|
|
381 $value %= 1;
|
|
|
382 }
|
|
|
383 $result;
|
|
|
384 }
|
|
|
385
|
|
|
386 sub _a_numeral {
|
|
|
387 my ($parens, $number) = @_;
|
|
|
388 my $result = '';
|
|
|
389 if ($number >= 5) {
|
|
|
390 $result .= "I" . (")" x (1 + $parens));
|
|
|
391 $number -= 5;
|
|
|
392 }
|
|
|
393 if ($number >= 1) {
|
|
|
394 $result .= (("(" x $parens) . "I" . (")" x $parens)) x $number;
|
|
|
395 }
|
|
|
396 $result;
|
|
|
397 }
|
|
|
398
|
|
|
399 1;
|
