Mercurial > repo

comparison interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/ReadNumbers.pm @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
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;