File Coverage

blib/lib/Roman/Unicode.pm

Criterion	Covered	Total	%
statement	94	102	92.1
branch	28	30	93.3
condition	9	9	100.0
subroutine	21	22	95.4
pod	8	8	100.0
total	160	171	93.5

use utf8;
use 5.014;

=encoding utf8

=head1 NAME

Roman::Unicode - Make roman numerals, using the Unicode characters for them

=head1 SYNOPSIS

	use Roman::Unicode qw( to_roman is_roman to_perl );

	my $perl_number  = to_perl( $roman ) if is_roman( $roman );
	my $roman_number = to_roman( $arabic );

=head1 DESCRIPTION

I made this module as a way to demonstrate various Unicode things without
mixing up natural language stuff. Surprisingly, roman numerals can do quite
a bit with that. You'll have to read the source to see it in action.

There are many fancy characters in this documentation, so you need a good
font that has the right glyphs. The Symbola font is a good one:
http://users.teilar.gr/~g1951d/

=head2 Functions

=over 4

=item is_roman( STRING )

Returns true if the string looks like a valid roman numeral. This
works with either the ASCII version or the ones using the characters
in the U+2160 to U+2188 range. You cannot mix the uppercase and lowercase
numerals.

=item to_perl( ROMAN )

If the argument is a valid roman numeral, C returns the Perl
number. Otherwise, it returns nothing.

=item to_roman( PERL_NUMBER )

If the argument is a valid Perl number, even if it is a string,
C returns the roman numeral representation. This uses the
characters in the U+2160 to U+2188 range.

If the number cannot be represented as roman numerals, this returns
nothing. Note that 0 doesn't have a roman numeral representation.

If you want the lowercase version, you can use C on the result.
However, some of the roman numerals don't have lowercase versions.

=item to_ascii( ROMAN )

If the argument is a valid roman numeral, it returns an ASCII
representation of it. Most of the numeral code points have compatible
decompositions, so the first step uses NFKD decomposition. For other
characters, it uses ASCII art representations:

	Roman       ASCII art
	------      ----------
	ↁ           |)
	ↂ          ((|))
	ↈ          (((|)))
	ↇ           |))

=back

=head2 Case mapping

As a demonstration of case mapping, I supply one function that uses
L. You can lexically override the case-mapping functions
as described in that module's documentation.

=over 4

=item to_roman_lower

A subroutine you can use with C. It's a bit more special
because it turns the higher magnitude characters into ASCII versions. That
means that the return value might not be a valid according to C. It
returns nothing if the input isn't a valid Roman numeral string.

You can also use this as a stand-alone function instead of C. That's the
smart way to do it, but then you don't get to play with C.

=back

=head2 User-defined properties

Perl lets you define your own properties, as documented in L. This
module defines several.

=over 4

=item IsRoman

The C property is a combination of C and
C.

=item IsUppercaseRoman

The C property matches these code points:

	Ⅰ       U+2160      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ᴏɴᴇ
	Ⅴ       U+2164      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ꜰɪᴠᴇ
	Ⅹ       U+2169      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ᴛᴇɴ
	Ⅼ       U+216C      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ꜰɪꜰᴛʏ
	Ⅽ       U+216D      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ᴏɴᴇ ʜᴜɴᴅʀᴇᴅ
	Ⅾ       U+216E      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ꜰɪᴠᴇ ʜᴜɴᴅʀᴇᴅ
	Ⅿ       U+216F      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ᴏɴᴇ ᴛʜᴏᴜsᴀɴᴅ
	ↁ       U+2181      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ꜰɪᴠᴇ ᴛʜᴏᴜsᴀɴᴅ
	ↂ      U+2182      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ᴛᴇɴ ᴛʜᴏᴜsᴀɴᴅ
	ↇ       U+2187      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ꜰɪꜰᴛʏ ᴛʜᴏᴜsᴀɴᴅ
	ↈ      U+2188      ʀᴏᴍᴀɴ ɴᴜᴍᴇʀᴀʟ ᴏɴᴇ ʜᴜɴᴅʀᴇᴅ ᴛʜᴏᴜsᴀɴᴅ

This excludes the other Roman numeral code points, such as Ⅻ (U+216B, ʀᴏᴍᴀɴ
ɴᴜᴍᴇʀᴀʟ ᴛᴡᴇʟᴠᴇ) since they are not designed to be part of larger strings of
Roman numerals.

=item IsLowercaseRoman

The C is the set of lowercase code points derived from the
set of code points in C. It checks each code point in
C and checks the Unicode Character Database (UCD) through
L to see if it has a lowercase mapping. If there is a lowercase
mapping, it makes it part of this property.

=back

=head1 LIMITATIONS

By using just the defined roman numerals characters in the Unicode Character
Set, you're limited to numbers less than 400,000 (although you could make
ↈↈↈↈ if you wanted, since that's not unheard of).

=head1 AUTHOR

brian d foy C<<  >>

This module started with the Roman module, credited to:

OZAWA Sakuro C<<  >> 1995-1997

Alexandr Ciornii, C<<  >> 2007

=head1 COPYRIGHT

Copyright © 2011-2021, brian d foy .

You can use this module under the terms of Artistic License 2.0.

=cut

package Roman::Unicode {
	use feature qw(unicode_strings);

	use strict;
	use warnings;
	use open IO => ':utf8';

	use Exporter 'import';
	our @EXPORT_OK = qw( is_roman to_perl to_roman to_ascii );
	our $VERSION = '1.032_02';

	use Unicode::UCD;
	use Unicode::Normalize qw(NFKD);

	# I'm specifically not using the characters for the other roman numerals
	# because those are meant to stand alone, as they might in a clock face
	our %valid_roman = map { $_, 1 } (
		# the capitals U+2160 to U+216F, U+2180 to U+2182, U+2187 to U+2188
		qw(Ⅰ Ⅴ Ⅹ Ⅼ Ⅽ Ⅾ Ⅿ ↁ ↂ ↇ ↈ ),
		# the lowercase U+2170 to U+217f
		qw(ⅰ ⅴ ⅹ ⅼ ⅽ ⅾ ⅿ),
		# the ASCII
		qw(I V X L C D M),
		qw(i v x l c d m),

		);

	our %roman2arabic = qw(
		Ⅰ 1 Ⅴ 5 Ⅹ 10
		Ⅼ 50 Ⅽ 100 Ⅾ 500 Ⅿ 1000 ↁ 5000 ↂ 10000 ↇ 50000 ↈ 100000

		ⅰ 1 ⅴ 5 ⅹ 10
		ⅼ 50 ⅽ 100 ⅾ 500 ⅿ 1000
		);

	sub _get_chars { my @chars = $_[0] =~ /(\X)/ug }

	sub _highest_value {  (sort { $a <=> $b } values %roman2arabic)[-1] }

	sub is_roman($) {
		$_[0] =~ / \A \p{IsUppercaseRoman}+ \z /x
			or
		$_[0] =~ / \A \p{IsLowercaseRoman}+ \z /x
		}

	sub to_perl($) { # Stolen from Roman.pm, mostly
		is_roman $_[0] or return;
		my($last_digit) = _highest_value();
		my($arabic);

		foreach my $char ( _get_chars( $_[0] ) ) {
			my $digit = $roman2arabic{$char};
			$arabic -= 2 * $last_digit if $last_digit < $digit;
			$arabic += ($last_digit = $digit);
			}

		$arabic;
		}

	BEGIN {

	my %roman_digits = qw(
		1 ⅠⅤ
		10 ⅩⅬ
		100 ⅭⅮ
		1000 Ⅿↁ
		10000 ↂↇ
		100000 ↈↈↈↈ
		);

	my @figure = reverse sort keys %roman_digits;
	$roman_digits{$_} = [split(//, $roman_digits{$_}, 2)] foreach @figure;

	sub to_roman($) { # stolen from Roman.pm, mostly
		my( $arg ) = @_;

		{
		no warnings 'numeric';
		0 < $arg and $arg < 4 * _highest_value()  or return;
		}

		my($x, $roman) = ( '', '' );
		foreach my $figure ( @figure ) {
			my( $digit, $i, $v ) = (int( $arg/$figure ), @{$roman_digits{$figure}});

			$roman .= do {
				   if( 1 <= $digit and $digit <= 3 ) { $i x $digit }
				elsif( $digit == 4 )                 { "$i$v" }
				elsif( $digit == 5 )                 { $v }
				elsif( 6 <= $digit and $digit <= 8 ) { $v . $i x ($digit - 5) }
				elsif( $digit == 9 )                 { "$i$x" }
				};

			$arg -= $digit * $figure;
			$x = $i;
			}

		$roman;
		}
	}

	sub to_ascii {
		my( $roman ) = @_;
		return unless is_roman( $roman );

		$roman = Unicode::Normalize::NFKD( $roman );

		$roman =~ s/ↁ/|))/g;
		$roman =~ s/ↂ/((|))/g;
		$roman =~ s/ↈ/(((|)))/g;
		$roman =~ s/ↇ/|)))/g;

		$roman;
		}

	sub IsRoman {
		IsUppercaseRoman() . IsLowercaseRoman()
		}

	sub IsUppercaseRoman {
		return <<"CODE_NUMBERS";
2160
2164
2169
216C 216F
2181 2182
2187 2188
CODE_NUMBERS
		}

	sub IsLowercaseRoman {
		state $string;
		return $string if defined $string;

		my @codes = ();

		my $uppers = IsUppercaseRoman();
		open my $string_fh, '<', \ $uppers;
		while( my $line = <$string_fh> ) {
			my @n = map { hex } map { m/(\p{HexDigit}+)/g } $line;
			if( @n == 1 ) { push @codes, $n[0] }
			if( @n == 2 ) { push @codes, $n[0] .. $n[1] };
			}

		my @lowers = map { hex } map {
			my $char_info = Unicode::UCD::charinfo( $_ );
			$char_info->{lower} ? $char_info->{lower} : ();
			} @codes;

		$string = join "\n", map {
			sprintf( '%04X', $_ )
			} @lowers;

		$string .= "\n";
		}

    # Use this with Unicode::Casing, or not
	sub to_roman_lower {
		return unless &is_roman;

		my $lower = CORE::lc( $_[0] );

		$lower =~ s/ↁ/|)/g;       # ↁ U+2181
		$lower =~ s/ↂ/((|))/g;   # ↂ U+2182
		$lower =~ s/ↇ/|))/g;      # ↇ U+2187
		$lower =~ s/ↈ/(((|)))/g; # ↈ U+2188

		return $lower;
		}
 }

1;