http://qs321.pair.com?node_id=465241
Category: PerlMonks Related Scripts
Author/Contact Info Anonymous. I wish.
Description:

It tells you how many XP you have until your next modular promotion. It also makes change. Here's some sample output.

XP = 16780
16780.00 initiates
839.00 novices, 0 to promotion
335.60 acolytes, 30 to promotion
167.80 scribes, 80 to promotion
83.90 monks, 180 to promotion
33.56 friars, 280 to promotion
16.78 abbots, 780 to promotion
10.49 bishops, 780 to promotion
7.30 pontiffs, 680 to promotion
5.59 saints, 1780 to promotion
5 saints, a bishop, scribe, acolyte, novice, and 10 initiates
BEGIN {
    my @levels = ( initiate => 1,
                   novice => 20,
                   acolyte => 50,
                   scribe => 100,
                   monk => 200,
                   friar => 500,
                   abbot => 1000,
                   bishop => 1600,
                   pontiff => 2300,
                   saint => 3000 );
    while ( @levels ) {
        my ( $level, $xp ) = splice @levels, 0, 2;
        eval "sub $level () { $xp }";
    }
}
$xp = 0 + shift;

printf
"XP = $xp
%0.2f initiates
%0.2f novices, %d to promotion
%0.2f acolytes, %d to promotion
%0.2f scribes, %d to promotion
%0.2f monks, %d to promotion
%0.2f friars, %d to promotion
%0.2f abbots, %d to promotion
%0.2f bishops, %d to promotion
%0.2f pontiffs, %d to promotion
%.02f saints, %d to promotion
",
$xp / initiate,
$xp / novice,  novice  - ( $xp % novice ),
$xp / acolyte, acolyte - ( $xp % acolyte ),
$xp / scribe,  scribe  - ( $xp % scribe ),
$xp / monk,    monk    - ( $xp % monk ),
$xp / friar,   friar   - ( $xp % friar ),
$xp / abbot,   abbot   - ( $xp % abbot ),
$xp / bishop,  bishop  - ( $xp % bishop ),
$xp / pontiff, pontiff - ( $xp % pontiff ),
$xp / saint,   saint   - ( $xp % saint );

# I wish this was lisp.
for ( qw( saint pontiff bishop abbot friar monk scribe acolyte novice 
+initiate ) ) {
    eval "if ( \$xp >= $_ ) { push \@change, int( \$xp / $_ ) . \" ${_
+}s\";
                              \$xp %= $_ }";
}
for ( @change ) {
    if ( 1 == $_ ) {
        s/s$//;
    }
}

$_ = join( ', ', @change, ) . "\n";
# Replaced w/ NinthWave's code. No, I didn't read it first.
s<(?:^|\D)(1 [a-z]+(?:, 1 [a-z]+)*)>{
    my @ranks = $1 =~ /[a-z]+/g;
    " a " . join ', ', @ranks;
}ge;
s/^ //;
if ( /,.+,/ ) {
    s/(.+),([^,]+)/$1, and$2/;
}
print