File Coverage

blib/lib/Date/Korean.pm

Criterion	Covered	Total	%
statement	84	98	85.7
branch	23	34	67.6
condition	19	33	57.5
subroutine	14	15	93.3
pod	4	4	100.0
total	144	184	78.2

package Date::Korean;

use strict;
use warnings;
use version; our $VERSION = qv('0.0.2');
use base 'Exporter';
use DateTime;
use DateTime::Calendar::Julian;
use Date::ISO8601 qw/cjdn_to_ymd/;
use Date::Korean::Table;
use Carp;

our @EXPORT = qw/get_ganzi get_ganzi_ko sol2lun lun2sol/;

sub _calculate_ganzi {
    my($year,$month,$day,$leap) = @_;

    my @ganzis = ( ($year+56)%60, ($year*12+$month+13)%60 );
    ($year,$month,$day) = lun2sol($year,$month,$day,$leap);
    # mjd(Modified Julian Date)
    my $mjd = DateTime->new(year=>$year,month=>$month,day=>$day)->mjd;
    # solar 1582-10-15 -> mjd:-100840
    if ($mjd < -100840) {
        $mjd += DateTime::Calendar::Julian
                ->new(year=>$year,month=>$month,day=>$day)
                ->gregorian_deviation;
    }
    push @ganzis, ($mjd+50)%60;
    return @ganzis;
}

sub get_ganzi {
    return map { $CELESTIAL_STEMS[$_%10].$TERRESTRIAL_BRANCHES[$_%12] }
           _calculate_ganzi(@_);
}

sub get_ganzi_ko {
    return map { $CELESTIAL_STEMS_KO[$_%10].$TERRESTRIAL_BRANCHES_KO[$_%12] }
           _calculate_ganzi(@_);
}

sub sol2lun {

    my($year,$month,$day) = @_;

    my $days;
    eval {
        # Chronological Julian Day(cjd)
        $days = DateTime->new(year=>$year,month=>$month,day=>$day)->jd+0.5;
    };
    if ($@) { # Maybe valid Julian date.
        if ( $year<=1582 ) {
            eval {
                $days = DateTime::Calendar::Julian
                        ->new(year=>$year,month=>$month,day=>$day)->jd+0.5;
            };
            if ($@) {
                croak "Invalid date.";
            }
        }
        else {
            croak "Invalid date.";
        }
    }
    # solar 1582-10-15 -> cjd:2299161 ,After this are gregorian calendar range.
    if ( $days < 2299161 ) {  # julian calendar range
        # gregorian 1582-10~05 ~ 1582-10-14 dates do not exist.
        if ( $year==1582 && $month==10 && $day>=5 && $day<=14) {
            croak "The gregorian date does not exist\n";
        }
        $days = DateTime::Calendar::Julian
                ->new(year=>$year,month=>$month,day=>$day)->jd+0.5;
    }

    if ( $days<$MINDATE || $days>$MAXDATE ) {
        croak "The date is out of range."
    }

    $days -= $MINDATE;
    $month = _bisect(\@MONTHTABLE,$days);
    $year = _bisect(\@YEARTABLE,$month);
    ($month,$day) = ( $month-$YEARTABLE[$year]+1, $days-$MONTHTABLE[$month]+1);
    my $leap;
    if ( $LEAPTABLE[$year]!=0 && $LEAPTABLE[$year]<=$month ) {
        if ( $LEAPTABLE[$year] == $month ) {
            $leap = 1;
        }
        else {
            $leap = 0;
        }
        $month -= 1;
    }
    else {
        $leap = 0;
    }

    return ( $year+$BASEYEAR, $month, $day, $leap );
}

sub lun2sol {

    my($year,$month,$day,$leap) = @_;

    $year -= $BASEYEAR;

    unless ( $year>=0 && $year< $#YEARTABLE ) {
        croak "Year is out of range.";
    }

    unless ( $month>=1 && $month <=12 ) {
        croak "Month is out of range.";
    }

    if ( $leap!=0 && ($LEAPTABLE[$year]-1)!=$month ) {
        croak "Wrong leap month.";
    }

    my $months = $YEARTABLE[$year] + $month - 1;

    if ( $leap==1 && ($month+1)==$LEAPTABLE[$year] ) {
        $months += 1;
    }
    elsif ( $LEAPTABLE[$year]!=0 && $LEAPTABLE[$year]<=$month ) {
        $months += 1;
    }

    my $days = $MONTHTABLE[$months] + $day -1;

    if ( $day<1 || $days>=$MONTHTABLE[$months+1]) {
        croak "Wrong day.";
    }

    # 1582-10-15 -> cjd(chronical julian date):2299161
    if ( ($days+$MINDATE) < 2299161 ) {
        my ($y,$m,$d) = cjdn_to_ymd($days+$MINDATE);
        my $deviation = DateTime::Calendar::Julian
                        ->new(year=>$y,month=>$m,day=>$d)
                        ->gregorian_deviation;
        return cjdn_to_ymd($days+$MINDATE-$deviation);
    }
    else {
        return cjdn_to_ymd($days+$MINDATE);
    }
}

sub _bisect {
    my ($a,$x) = @_;
    my $lo = 0;
    my $hi = $#{$a};
    while ( $lo < $hi ) {
        my $mid = int( ($lo+$hi)/2 );
        if ( $x < $a->[$mid] ) {
            $hi = $mid;
        }
        else {
            $lo = $mid + 1;
        }
    }

    return $lo-1;
}

1;
__END__