--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/ReadNumbers.pm	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,399 @@
+package Language::INTERCAL::ReadNumbers;
+
+# Convert numbers to Roman numerals
+
+# This file is part of CLC-INTERCAL
+
+# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
+
+# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
+# and distribute it is granted provided that the conditions set out in the
+# licence agreement are met. See files README and COPYING in the distribution.
+
+use strict;
+use vars qw($VERSION $PERVERSION);
+($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/ReadNumbers.pm 1.-94.-2") =~ /\s(\S+)$/;
+
+use Carp;
+use Language::INTERCAL::Exporter '1.-94.-2';
+use Language::INTERCAL::Splats '1.-94.-2', qw(SP_ROMAN faint);
+use vars qw(@EXPORT @EXPORT_OK);
+@EXPORT = ();
+@EXPORT_OK = qw(roman_type roman_name roman_type_default read_number roman);
+
+my (@roman_types, %roman_types);
+
+BEGIN {
+    @roman_types = (
+	['CLC'         => \&_roman_clc],         # CLC-INTERCAL's "roman"
+	['UNDERLINE'   => \&_roman_underline],   # alternative CLC-INTERCAL's
+	['ARCHAIC'     => \&_roman_archaic],     # as used when Rome was new
+	['MEDIAEVAL'   => \&_roman_mediaeval],   # as used in the middle ages
+	['MODERN'      => \&_roman_modern],      # as used today
+	['TRADITIONAL' => \&_roman_1972],        # INTERCAL-1972
+	['WIMPMODE'    => \&_roman_wimpmode],    # not Roman at all
+    );
+
+    %roman_types =
+	map { ( $roman_types[$_][0] => $_ + 1 ) } (0..@roman_types - 1);
+
+    my $d = $roman_types{'CLC'};
+    use vars '*roman_type_default';
+    *roman_type_default = sub () { $d };
+}
+
+sub roman_type {
+    @_ == 1 or croak "Usage: roman_type(TYPE)";
+    my ($type) = @_;
+    $type =~ s/\s+//g;
+    if ($type =~ /^\d+$/) {
+	return roman_type_default if $type == 0;
+	return $type < 1 || $type > @roman_types ? undef : $type;
+    } else {
+	return exists $roman_types{$type} ? $roman_types{$type} : undef;
+    }
+}
+
+sub roman_name {
+    @_ == 1 or croak "Usage: roman_name(TYPE)";
+    my ($type) = @_;
+    $type = roman_type_default if $type == 0;
+    return undef if $type < 1 || $type > @roman_types;
+    return $roman_types[$type - 1][0];
+}
+
+sub read_number {
+    @_ == 3 or croak "Usage: read_number(NUMBER, TYPE, FILEHANDLE)";
+    my ($number, $type, $fh) = @_;
+    my $rtype = roman_type($type);
+    defined $rtype or faint(SP_ROMAN, $type);
+    for my $line (&{$roman_types[$rtype - 1][1]}($number)) {
+	$fh->read_text($line . "\n");
+    }
+}
+
+sub roman {
+    @_ == 2 or croak "Usage: read_number(NUMBER, TYPE)";
+    my ($number, $type, $fh) = @_;
+    my $rtype = roman_type($type);
+    defined $rtype or faint(SP_ROMAN, $type);
+    return &{$roman_types[$rtype - 1][1]}($number);
+}
+
+sub _roman_clc {
+    my ($number) = @_;
+    if ($number == 0) {
+	return "NIHIL";
+    }
+    my $result = '';
+    if ($number >= 4000000000) {
+	my $val = lc(_numeral(int($number / 1000000000)));
+	$val =~ s/(.)/\\$1/g;
+	$result .= $val;
+	$number %= 1000000000;
+    }
+    if ($number >= 4000000) {
+	my $val = uc(_numeral(int($number / 1000000)));
+	$val =~ s/(.)/\\$1/g;
+	$result .= $val;
+	$number %= 1000000;
+    }
+    if ($number >= 4000) {
+	$result .= lc(_numeral(int($number / 1000)));
+	$number %= 1000;
+    }
+    if ($number > 0) {
+	$result .= uc(_numeral($number));
+    }
+    $result;
+}
+
+sub _roman_underline {
+    my ($number) = @_;
+    if ($number == 0) {
+	return "NIHIL";
+    }
+    my $result = '';
+    if ($number >= 4000000000) {
+	my $val = lc(_numeral(int($number / 1000000000)));
+	$val =~ s/(.)/_\b$1/g;
+	$result .= $val;
+	$number %= 1000000000;
+    }
+    if ($number >= 4000000) {
+	my $val = uc(_numeral(int($number / 1000000)));
+	$val =~ s/(.)/_\b$1/g;
+	$result .= $val;
+	$number %= 1000000;
+    }
+    if ($number >= 4000) {
+	$result .= lc(_numeral(int($number / 1000)));
+	$number %= 1000;
+    }
+    if ($number > 0) {
+	$result .= uc(_numeral($number));
+    }
+    $result;
+}
+
+sub _roman_mediaeval {
+    my ($number) = @_;
+    if ($number == 0) {
+	return "NIHIL";
+    }
+    my $first = '';
+    my $second = '';
+    if ($number >= 500000000) {
+	my $val = uc(_m_numeral(int($number / 500000000) * 5));
+	$first .= '  _  ' x length($val);
+	$val =~ s/(.)/||$1||/g;
+	$second .= $val;
+	$number %= 500000000;
+    }
+    if ($number >= 5000000) {
+	my $val = uc(_m_numeral(int($number / 5000000) * 5));
+	$first .= ' _ ' x length($val);
+	$val =~ s/(.)/|$1|/g;
+	$second .= $val;
+	$number %= 5000000;
+    }
+    if ($number >= 5000) {
+	my $val = uc(_m_numeral(int($number / 5000) * 5));
+	$first .= '_' x length($val);
+	$second .= $val;
+	$number %= 5000;
+    }
+    if ($number > 0) {
+	my $val = uc(_m_numeral($number));
+	$first .= ' ' x length($val);
+	$second .= $val;
+    }
+    $first =~ s/\s+$//;
+    $first ne '' ? ($first, $second) : ($second);
+}
+
+sub _roman_modern {
+    my ($number) = @_;
+    if ($number == 0) {
+	return "NIHIL";
+    }
+    my $first = '';
+    my $second = '';
+    if ($number >= 100000000) {
+	my $val = uc(_numeral(int($number / 100000000) * 10));
+	$first .= '  _  ' x length($val);
+	$val =~ s/(.)/||$1||/g;
+	$second .= $val;
+	$number %= 100000000;
+    }
+    if ($number >= 1000000) {
+	my $val = uc(_numeral(int($number / 1000000) * 10));
+	$first .= ' _ ' x length($val);
+	$val =~ s/(.)/|$1|/g;
+	$second .= $val;
+	$number %= 1000000;
+    }
+    if ($number >= 1000) {
+	my $val = uc(_numeral(int($number / 1000)));
+	$first .= '_' x length($val);
+	$second .= $val;
+	$number %= 1000;
+    }
+    if ($number > 0) {
+	my $val = uc(_numeral($number));
+	$first .= ' ' x length($val);
+	$second .= $val;
+    }
+    $first =~ s/\s+$//;
+    $first ne '' ? ($first, $second) : ($second);
+}
+
+sub _roman_wimpmode {
+    my ($number) = @_;
+    $number + 0;
+}
+
+sub _roman_archaic {
+    my ($number) = @_;
+    if ($number == 0) {
+	return "NIHIL";
+    }
+    my $result = '';
+    if ($number >= 1000000000) {
+	$result .= _a_numeral(7, int($number / 1000000000));
+	$number %= 1000000000;
+    }
+    if ($number >= 100000000) {
+	$result .= _a_numeral(6, int($number / 100000000));
+	$number %= 100000000;
+    }
+    if ($number >= 10000000) {
+	$result .= _a_numeral(5, int($number / 10000000));
+	$number %= 10000000;
+    }
+    if ($number >= 1000000) {
+	$result .= _a_numeral(4, int($number / 1000000));
+	$number %= 1000000;
+    }
+    if ($number >= 100000) {
+	$result .= _a_numeral(3, int($number / 100000));
+	$number %= 100000;
+    }
+    if ($number >= 10000) {
+	$result .= _a_numeral(2, int($number / 10000));
+	$number %= 10000;
+    }
+    if ($number >= 1000) {
+	$result .= _a_numeral(1, int($number / 1000));
+	$number %= 1000;
+    }
+    if ($number >= 500) {
+	$result .= 'I)';
+	$number -= 500;
+    }
+    if ($number >= 1) {
+	$result .= uc(_m_numeral($number));
+    }
+    $result;
+}
+
+sub _roman_1972 {
+    my ($number) = @_;
+    if ($number == 0) {
+	return "_", " ";
+    }
+    my $first = '';
+    my $second = '';
+    if ($number >= 4000000000) {
+	my $val = lc(_numeral(int($number / 1000000000)));
+	$first .= '_' x length($val);
+	$second .= $val;
+	$number %= 1000000000;
+    }
+    if ($number >= 4000000) {
+	my $val = lc(_numeral(int($number / 1000000)));
+	$first .= ' ' x length($val);
+	$second .= $val;
+	$number %= 1000000;
+    }
+    if ($number >= 4000) {
+	my $val = uc(_numeral(int($number / 1000)));
+	$first .= '_' x length($val);
+	$second .= $val;
+	$number %= 1000;
+    }
+    if ($number > 0) {
+	my $val = uc(_numeral($number));
+	$first .= ' ' x length($val);
+	$second .= $val;
+    }
+    $first =~ s/\s+$//;
+    ($first, $second);
+}
+
+sub _numeral {
+    my ($value) = @_;
+    my $result = '';
+    if ($value >= 1000) {
+	$result .= 'M' x int($value / 1000);
+	$value %= 1000;
+    }
+    if ($value >= 900) {
+	$result .= 'CM';
+	$value -= 900;
+    }
+    if ($value >= 500) {
+	$result .= 'D';
+	$value -= 500;
+    }
+    if ($value >= 400) {
+	$result .= 'CD';
+	$value -= 400;
+    }
+    if ($value >= 100) {
+	$result .= 'C' x int($value / 100);
+	$value %= 100;
+    }
+    if ($value >= 90) {
+	$result .= 'XC';
+	$value -= 90;
+    }
+    if ($value >= 50) {
+	$result .= 'L';
+	$value -= 50;
+    }
+    if ($value >= 40) {
+	$result .= 'XL';
+	$value -= 40;
+    }
+    if ($value >= 10) {
+	$result .= 'X' x int($value / 10);
+	$value %= 10;
+    }
+    if ($value >= 9) {
+	$result .= 'IX';
+	$value -= 9;
+    }
+    if ($value >= 5) {
+	$result .= 'V';
+	$value -= 5;
+    }
+    if ($value >= 4) {
+	$result .= 'IV';
+	$value -= 4;
+    }
+    if ($value >= 1) {
+	$result .= 'I' x $value;
+	$value %= 1;
+    }
+    $result;
+}
+
+sub _m_numeral {
+    my ($value) = @_;
+    my $result = '';
+    if ($value >= 1000) {
+	$result .= 'M' x int($value / 1000);
+	$value %= 1000;
+    }
+    if ($value >= 500) {
+	$result .= 'D';
+	$value -= 500;
+    }
+    if ($value >= 100) {
+	$result .= 'C' x int($value / 100);
+	$value %= 100;
+    }
+    if ($value >= 50) {
+	$result .= 'L';
+	$value -= 50;
+    }
+    if ($value >= 10) {
+	$result .= 'X' x int($value / 10);
+	$value %= 10;
+    }
+    if ($value >= 5) {
+	$result .= 'V';
+	$value -= 5;
+    }
+    if ($value >= 1) {
+	$result .= 'I' x $value;
+	$value %= 1;
+    }
+    $result;
+}
+
+sub _a_numeral {
+    my ($parens, $number) = @_;
+    my $result = '';
+    if ($number >= 5) {
+	$result .= "I" . (")" x (1 + $parens));
+	$number -= 5;
+    }
+    if ($number >= 1) {
+	$result .= (("(" x $parens) . "I" . (")" x $parens)) x $number;
+    }
+    $result;
+}
+
+1;