File Coverage

blib/lib/Date/Maya.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	28	28	100.0
condition	2	3	66.6
subroutine	12	12	100.0
pod	0	3	0.0
total	113	117	96.5

package Date::Maya;

use 5.006;

use strict;
use integer;
use warnings;
no  warnings 'syntax';
use Exporter;

our $VERSION     = '2010011301';


our @ISA         = qw (Exporter);
our @EXPORT      = qw (julian_to_maya maya_to_julian);
our @EXPORT_OK   = qw (MAYA_EPOCH1 MAYA_EPOCH2 MAYA_EPOCH3 maya_epoch);
our %EXPORT_TAGS =    (MAYA_EPOCH => [qw /MAYA_EPOCH1 MAYA_EPOCH2
                                                      MAYA_EPOCH3/]);


use constant MAYA_EPOCH1 => 584285;  # 13 Aug 3114 BC, Gregorian.
use constant MAYA_EPOCH2 => 584283;  # 11 Aug 3114 BC, Gregorian.
use constant MAYA_EPOCH3 => 489384;  # 15 Oct 3374 BC, Gregorian.

my $epoch = MAYA_EPOCH1;

sub maya_epoch ($) {$epoch = shift;}


my $date_parts   = [
    [kin         =>     20],
    [unial       =>     18],
    [tun         =>     20],
    [katun       =>     20],
    [baktun      =>     20],
    [pictun      =>     20],
    [calabtun    =>     20],
    [kinchiltun  =>     20],
    [alautun     =>  undef],
];

my $max_baktun   = 13;

my @tzolkin = qw /Ahau Imix Ik Akbal Kan Chicchan Cimi Manik Lamat Muluc
                  Oc Chuen Eb Ben Ix Men Cib Caban Etznab Caunac/;

my $tzolkin_sweek_length = 13;
my $tzolkin_sweek_offset =  4;

my @haab    = qw /Pop Uo Zip Zotz Tzec Xul Yaxkin Mol Chen Yax Zac Ceh
                  Mac Kankin Muan Pax Kayab Cumku/;

my $haab_month_length =   20;
my $haab_uayeb_length =    5;
my $haab_year_length  = $haab_month_length * @haab;
my $haab_fyear_length = $haab_year_length  + $haab_uayeb_length;
my $haab_offset       =  348;  # 8 Cumku.


sub julian_to_maya ($) {
    die "No argument to julian_to_maya\n" unless @_;

    my $julian = shift;

    die "Undefined argument to julian_to_maya\n" unless defined $julian;
    die "Illegal argument `$julian' to julian_to_maya\n" if $julian =~ /\D/;

    my $days   = $julian - $epoch;
    die "Cannot deal with dates before epoch.\n" if $days < 0;

    # Calculation of the Long Count.
    my @results;

    foreach my $part (@$date_parts) {
        push @results  => $days % $part -> [1];
        last if $part  -> [0] eq "baktun";
        $days /= $part -> [1];
    }

    @results       = reverse @results;
    $results [0]  %= $max_baktun;
    $results [0]   = $max_baktun if $results [0] == 0;

    my $long_count = join "." => @results;

    unless (wantarray) {
        return $long_count;
    }


    # Calculation of the Tzolkin.
    my $tzolkin_day = ($julian - $epoch + $tzolkin_sweek_offset) %
                                          $tzolkin_sweek_length;
       $tzolkin_day =  $tzolkin_sweek_length if $tzolkin_day == 0;

    my $tzolkin     = "$tzolkin_day $tzolkin[$results[4]]";


    # Calculation of the Haab.
    my $haab_y_day = ($julian - $epoch + $haab_offset) % $haab_fyear_length;
    my $haab;
    if ($haab_y_day >= $haab_year_length) {
        $haab = ($haab_y_day - $haab_year_length) . " Uayeb";
    }
    else {
        $haab =  join " " => ($haab_y_day % $haab_month_length),
                       $haab [$haab_y_day / $haab_month_length];
    }

    ($long_count, $tzolkin, $haab);
}



sub maya_to_julian ($) {
    die "Failed to supply argument to maya_to_julian\n" unless @_;

    my $maya = shift;

    die "Undefined argument to maya_to_julian\n" unless defined $maya;

    my @parts = split /\./ => $maya;
    die "Illegal argument `$maya' to maya_to_julian\n"
         unless 5 == @parts && !grep {/\D/} @parts;
    # Normalize the baktun.
    $parts [0] = 0 if $parts [0] == $max_baktun;

    my $julian = $epoch;

    my $mod = 1;
    my $i   = 0;
    foreach my $part (reverse @parts) {
        if ($part >= $date_parts -> [$i] -> [1]) {
            die "Out of bounds argument to maya_to_julian\n";
        }
        $julian += $part * $mod;
        $mod    *= $date_parts -> [$i] -> [1];
        $i ++;
    }

    $julian;
}

__END__