File Coverage

blib/lib/DateTime/Calendar/Chinese.pm

Criterion	Covered	Total	%
statement	17	19	89.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	24	26	92.3

package DateTime::Calendar::Chinese;
use 5.008;
use strict;
use utf8;
use vars qw($VERSION);
BEGIN {
    $VERSION = '1.00';
}

use DateTime;
use DateTime::Astro qw(MEAN_TROPICAL_YEAR MEAN_SYNODIC_MONTH moment dt_from_moment new_moon_after new_moon_before
    solar_longitude_from_moment
);
use DateTime::Event::Chinese qw(chinese_new_year_before);
use DateTime::Event::SolarTerm qw(prev_term_at no_major_term_on);
use Params::Validate;
use Math::Round qw(round);
use constant GREGORIAN_CHINESE_EPOCH => DateTime->new(
    year => -2636, month => 2, day => 15, time_zone => 'UTC');
use constant GREGORIAN_CHINESE_EPOCH_MOMENT => moment(GREGORIAN_CHINESE_EPOCH);
use constant DEBUG => $ENV{PERL_DATETIME_CALENDAR_CHINESE_DEBUG};

my %BasicValidate = (
    cycle => {
        default => 1,
    },
    cycle_year  => {
        default   => 1,
        callbacks => {
            'is between 1 and 60' => sub { $_[0] >= 1 && $_[0] <= 60 }
        }
    },
    month => {
        default   => 1,
        callbacks => {
            'is between 1 and 12' => sub { $_[0] >= 1 && $_[0] <= 12 }
        }
    },
    leap_month => {
        default => 0,
        type => Params::Validate::BOOLEAN()
    },
    day        => {
        default   => 1,
        type => Params::Validate::SCALAR()
    },
    hour   => {
        type => Params::Validate::SCALAR(), default => 0,
        callbacks => {
            'is between 0 and 23' => sub { $_[0] >= 0 && $_[0] <= 23 },
        },
    },
    minute => {
        type => Params::Validate::SCALAR(), default => 0,
        callbacks => {
            'is between 0 and 59' => sub { $_[0] >= 0 && $_[0] <= 59 },
        },
    },
    second => {
        type => Params::Validate::SCALAR(), default => 0,
        callbacks => {
            'is between 0 and 61' => sub { $_[0] >= 0 && $_[0] <= 61 },
        },
    },
    nanosecond => {
        type => Params::Validate::SCALAR(), default => 0,
        callbacks => {
            'cannot be negative' => sub { $_[0] >= 0 },
        }
    },
    locale    => { type => Params::Validate::SCALAR() | Params::Validate::OBJECT(), optional => 1 },
    language  => { type => Params::Validate::SCALAR() | Params::Validate::OBJECT(), optional => 1 },
);

my %NewValidate = (
    %BasicValidate,
    time_zone  => { type => Params::Validate::SCALAR() | Params::Validate::OBJECT(), default => 'Asia/Shanghai' },
);
sub new
{
    my $class = shift;
    my %args  = Params::Validate::validate(@_, \%NewValidate);

    # XXX - currently _calc_gregorian_components() calculates the
    # date component only, then we set the time
    my %hash;
    $hash{cycle}      = delete $args{cycle};
    $hash{cycle_year} = delete $args{cycle_year};
    $hash{month}      = delete $args{month};
    $hash{leap_month} = delete $args{leap_month};
    $hash{day}        = delete $args{day};

    my $self  = bless \%hash, $class;
    $self->_calc_gregorian_components(time_zone => delete $args{time_zone});
    $self->{gregorian}->set(%args);

    $self;
}

# XXX - these values are proxied directly to the underlying DateTime
# (Gregorian) object.
sub utc_rd_values { $_[0]->{gregorian}->utc_rd_values }
sub hour          { $_[0]->{gregorian}->hour }
sub minute        { $_[0]->{gregorian}->minute }
sub second        { $_[0]->{gregorian}->second }
sub nanosecond    { $_[0]->{gregorian}->nanosecond }
sub day_of_week   { $_[0]->{gregorian}->day_of_week }
sub time_zone     { $_[0]->{gregorian}->time_zone }
sub set_time_zone { shift->{gregorian}->set_time_zone(@_) }

# XXX - accessors for DT::C::C specific fields
sub cycle      { $_[0]->{cycle} }
sub cycle_year { $_[0]->{cycle_year} }
sub month      { $_[0]->{month} }
sub leap_month { $_[0]->{leap_month} }
sub day        { $_[0]->{day} }

my @celestial_stems =
    ( "甲",
      "乙",
      "丙",
      "丁",
      "戊",
      "å·±",
      "庚",
      "辛",
      "壬",
      "癸",
    );

my @celestial_stems_py =
    qw( jia3
        yi3
        bing3
        ding1
        wu4
        ji3
        geng1
        xin1
        ren2
        gui3
      );

my @terrestrial_branches =
    ( "子",
      "丑",
      "寅",
      "卯",
      "è¾°",
      "å·³",
      "午",
      "未",
      "申",
      "酉",
      "戌",
      "亥",
    );

my @terrestrial_branches_py =
    qw( zi
        chou3
        yin2
        mao3
        chen2
        si4
        wu3
        wei4
        shen1
        you3
        xu1
        hai4
      );

my @zodiac_animals =
    qw( rat
        ox
        tiger
        hare
        dragon
        snake
        horse
        sheep
        monkey
        fowl
        dog
        pig
      );

sub celestial_stem     { $celestial_stems[ ( $_[0]->cycle_year % 10 || 10) - 1 ] }
sub terrestrial_branch { $terrestrial_branches[ ( $_[0]->cycle_year % 12 || 12 ) - 1 ] }
sub year_name          { $_[0]->celestial_stem . $_[0]->terrestrial_branch }

sub celestial_stem_py     { $celestial_stems_py[ ( $_[0]->cycle_year % 10 || 10 ) - 1 ] }
sub terrestrial_branch_py { $terrestrial_branches_py[ ( $_[0]->cycle_year % 12 || 12 ) - 1 ] }
sub year_name_py          { $_[0]->celestial_stem_py . $_[0]->terrestrial_branch_py }

sub zodiac_animal         { $zodiac_animals[ ( $_[0]->cycle_year % 12 || 12 ) - 1 ] }

my %SetValidate;
foreach my $key (keys %BasicValidate) {
    my %hash = %{$BasicValidate{$key}};
    delete $hash{default};
    $hash{optional} = 1;
    $SetValidate{$key} = \%hash;
}

sub set
{
    my $self = shift;
    my %args  = Params::Validate::validate(@_, \%SetValidate);

#print STDERR
#    "BEFORE SET ",
#    "grgorian: ", $self->{gregorian}->datetime,
#    " RD: ", ($self->{gregorian}->utc_rd_values)[0],
#    " time_zone: ", $self->{gregorian}->time_zone_short_name, "\n";
    foreach my $ch_component (qw(cycle cycle_year month leap_month day)) {
        if (exists $args{$ch_component}) {
            $self->{$ch_component} = delete $args{$ch_component};
        }
    }

    my $clone = $self->{gregorian}->clone;

    $self->_calc_gregorian_components(time_zone =>
        $args{time_zone} || $clone->time_zone || 'UTC');

    # get "defaults" from the cloned dt object. we will only use these
    # values if the field wasn't specified in the argument to set()
    foreach my $dt_component (qw(hour minute second locale)) {
        if (! exists $args{$dt_component}) {
            $args{$dt_component} = $clone->$dt_component;
        }
    }
    $self->{gregorian}->set(%args);

#print STDERR
#    "AFTER SET ",
#    "grgorian: ", $self->{gregorian}->datetime,
#    " RD: ", ($self->{gregorian}->utc_rd_values)[0],
#    " time_zone: ", $self->{gregorian}->time_zone_short_name, "\n";

    $self;
}

sub from_epoch
{
    my $class = shift;
    my $self  = bless {}, $class;
    my $dt    = DateTime->from_epoch(@_);
    $self->{gregorian} = $dt;
    $self->_calc_local_components();
    return $self;

}
sub now { shift->from_epoch(@_, epoch => time()) }

sub from_object
{
    my $class = shift;
    my $self  = bless {}, $class;
    my $dt    = DateTime->from_object(@_);

    $self->{gregorian} = $dt;
    $self->_calc_local_components();
    return $self;
}

sub _calc_gregorian_components
{
    my $self = shift;

    my $mid_year = POSIX::floor(
        GREGORIAN_CHINESE_EPOCH_MOMENT +
        (($self->cycle() - 1) * 60 + $self->cycle_year() - 1 + 0.5) *
        MEAN_TROPICAL_YEAR);
    my $new_year = chinese_new_year_before(dt_from_moment($mid_year) );

    # XXX - I don't know why I need to do $self->month() - 2 here
    my $p_dt = $new_year + DateTime::Duration->new(days => ($self->month() - 2) * 29);
    my $p = new_moon_after( $p_dt );
    my $d = DateTime::Calendar::Chinese->from_object(object => $p);

    my $prior_new_moon;
    if ($d->month == $self->month && $d->leap_month == $self->leap_month) {
        $prior_new_moon = $p;
    } else {
        $prior_new_moon = new_moon_after( $p + DateTime::Duration->new(days => 1) );
    }

    my $tmp = $prior_new_moon + DateTime::Duration->new(days => $self->day - 1);
    my %args = @_;
    my %new_args = ();
    foreach my $component (qw(
        year month day hour minute second nanosecond locale)) {

        $new_args{$component} = $tmp->$component;
    }
    if ($args{time_zone}) {
        $new_args{time_zone} = $args{time_zone};
    } else {
        $new_args{time_zone} = $tmp->time_zone;
    }

    $self->{gregorian} = DateTime->new(%new_args);

#print STDERR
#    ">>>>>>>\n",
#    "   cycle: ", $self->cycle, "\n",
#    "  c_year: ", $self->cycle_year, "\n",
#    "mid_year: ", dt_from_moment($mid_year)->datetime, "\n",
#    "new_year: ", $new_year->datetime, "\n",
#    "       p: ", $p->datetime, "\n",
#    "    p_dt: ", $p_dt->datetime, "\n",
#    "prior_nm: ", $prior_new_moon->datetime, "\n",
#    "    self: cycle: ", $self->cycle, " cycle_year: ", $self->cycle_year,
#        " month: ", $self->month, " leap_month: ", $self->leap_month,
#        " day: ", $self->day, "\n",
#    "       d: cycle: ", $d->cycle, " cycle_year: ", $d->cycle_year,
#        " month: ", $d->month, " leap_month: ", $d->leap_month,
#        " day: ", $d->day, "\n";
#    "grgorian: ", $self->{gregorian}->datetime, "\n",
#    "<<<<<<<\n";

}

sub _calc_local_components
{
    my $self = shift;
    my $dt   = $self->{gregorian}->clone->truncate(to => 'day');

    # XXX TODO: Change these calculations to use moment, not DateTime

    # last winter solstice
    my $s1 = prev_term_at( $dt, 270 );
    # next winter solstice
    my $s2 = prev_term_at( $s1 + DateTime::Duration->new(days => 370), 270 );

    # new moon after the last winter solstice (12th month in the last sui)
    my $m12 = new_moon_after($s1 + DateTime::Duration->new(days => 1) );

    # new moon before the next winter solstice (11th month in the current sui)
    my $next_m11 = new_moon_before($s2 + DateTime::Duration->new(days => 1));

    # new moon before now.
    my $m = new_moon_before($dt + DateTime::Duration->new(days => 1));

    # pre-compute and save a call to moment()
    my $m12_moment = moment($m12);
    my $m_moment   = moment($m);
    my $m11_moment = moment($next_m11);


    # if there are 12 lunar months (29.5 days) between the last 12th month
    # and the next 11th month, then there must be a leap month some where
    my $leap_year =
        round(($m11_moment - $m12_moment) / MEAN_SYNODIC_MONTH) == 12;

    # XXX - hey, there are a lot of paranthesis, but it's required or
    # else you get into some real unhappy problems
    my $month;
    {
        my $x = round(($m_moment - $m12_moment) / MEAN_SYNODIC_MONTH);
        if ($leap_year && $self->_prior_leap_month($m12, $m)) {
            if (DEBUG) {
                print STDERR ">>>> leap_year && prior_leap_mont $m12 : $m\n";
            }
            $x--;
        }
        $month = $x % 12 || 12;
    }

    # XXX - tricky... we need to set month before calling elapsed_years,
    # because it will be used by that function
    $self->{month}    = $month;
    my $elapsed_years = $self->elapsed_years;

    $self->{cycle}      = POSIX::floor( ($elapsed_years - 1) / 60) + 1;
    $self->{cycle_year} = $elapsed_years % 60 || 60;
    $self->{day}        = POSIX::ceil(moment($dt) - $m_moment + 1);

    if ($leap_year && no_major_term_on($m)) {
        my $end = new_moon_before($m - DateTime::Duration->new(days => 1));
        $self->{leap_month} = ! $self->_prior_leap_month($m12, $end);
    } else {
        $self->{leap_month} = 0;
    }

    if (DEBUG) {
        print STDERR
            ">>>>>>\n",
            "        dt: ", $dt->datetime, "\n",
            "        s1: ", $s1->datetime, "\n",
            "        s2: ", $s2->datetime, "\n",
            "       m12: ", $m12->datetime, "\n",
            "     n_m11: ", $next_m11->datetime, "\n",
            "     11-12: ", round( (moment($next_m11) - $m12_moment) / MEAN_SYNODIC_MONTH), "\n",
            "         m: ", $m->datetime, "\n",
            " leap year: ", $leap_year ? "yes" : "no", "\n",
            "leap month: ", $self->{leap_month} ? "yes" : "no", "\n",
            "     m-m12: ", round(abs($m_moment - $m12_moment) / MEAN_SYNODIC_MONTH), "\n",
            "      sl_m: ", solar_longitude_from_moment($m_moment), "\n",
            "    sl_m12: ", solar_longitude_from_moment($m12_moment), "\n",

#            "pleap: ", $self->_prior_leap_month($m12, $m) ? "yes" : "no", "\n",
            "     month: ", $month, "\n",
            "   elapsed: ", $elapsed_years, "\n",
            "     cycle: ", $self->{cycle}, "\n",
            "cycle_year: ", $self->{cycle_year}, "\n",
            "<<<<<<\n";
    }

}

sub elapsed_years
{
    my $self = shift;
    if (DEBUG) {
        print  STDERR
            ">>>> elapsed_years\n",
            "moment: ", moment($self->{gregorian}), "\n",
            "epoch:  ", GREGORIAN_CHINESE_EPOCH_MOMENT, "\n",
            "month:  ", $self->month, "\n",
            "<<<<\n"
    }
    return POSIX::floor(
        1.5 - $self->month / 12 + (moment($self->{gregorian}) - GREGORIAN_CHINESE_EPOCH_MOMENT) / MEAN_TROPICAL_YEAR);
}

# [1] p.250
sub _prior_leap_month
{
    my($class, $start, $end) = @_;

    if (DEBUG) {
        print STDERR
            ">>>> prior_leap_month\n",
            "caller: ", join(':', (caller)[1, 2]), "\n",
            "start: ", $start, "\n",
            "end:   ", $end, "\n",
            "<<<<\n";
    }

    while ($start <= $end) {
        if (no_major_term_on($end)) {
            if (DEBUG) {
                print STDERR " + prior_leap_month: there are no major terms on $end\n";
            }
            return 1;
        }

        $end = new_moon_before($end - DateTime::Duration->new(minutes => 30));
    }
    if (DEBUG) {
        print " + prior_leap_month: nothing found, returning false\n";
    }

    return ();
}

1;
__END__