DateTime::Calendar::Chinese - Traditional Chinese Calendar Implementation

  use DateTime::Calendar::Chinese;

  my $dt = DateTime::Calendar::Chinese->now();
  my $dt = DateTime::Calendar::Chinese->new(
    cycle      => $cycle,
    cycle_year => $cycle_year,
    month      => $month,
    leap_month => $leap_month,
    day        => $day,
  );

  $dt->cycle;
  $dt->cycle_year; # 1 - 60
  $dt->month;      # 1-12
  $dt->leap_month; # true/false
  $dt->day;        # 1-30 
  $dt->elapsed_years; # years since "Chinese Epoch"

  my ($rd_days, $rd_secs, $rd_nanosecs) = $dt->utc_rd_values();

    Celestial Stems         Terrestrial Branches
  -------------------     -----------------------
  | Jia3            |     | Zi (Rat)            |
  -------------------     -----------------------
  | Yi3             |     | Chou3 (Ox)          |
  -------------------     -----------------------
  | Bing3           |     | Yin2 (Tiger)        |
  -------------------     -----------------------
  | Ding1           |     | Mao3 (Hare)         |
  -------------------     -----------------------
  | Wu4             |     | Chen2 (Dragon)      |
  -------------------     -----------------------
  | Ji3             |     | Si4 (Snake)         |
  -------------------     -----------------------
  | Geng1           |     | Wu3 (Horse)         |
  -------------------     -----------------------
  | Xin1            |     | Wei4 (Sheep)        |
  -------------------     -----------------------
  | Ren2            |     | Shen1 (Monkey)      |
  -------------------     -----------------------
  | Gui3            |     | You3 (Fowl)         |
  -------------------     -----------------------
                          | Xu1 (Dog)           |
                          -----------------------
                          | Hai4 (Pig)          |
                          -----------------------

  XXX The time zone settings may change in a few ture version such
  XXX that the calculation is done in Asia/Shanghai, but the
  XXX resulting object is set to "floating" time zone.

  [1] Edward M. Reingold, Nachum Dershowitz
      "Calendrical Calculations (Millenium Edition)", 2nd ed.
       Cambridge University Press, Cambridge, UK 2002

# $Id: /local/datetime/modules/DateTime-Calendar-Chinese/trunk/lib/DateTime/Calendar/Chinese.pm 11710 2007-05-28T15:03:19.325281Z daisuke  $
#
# Copyright (c) 2004-2007 Daisuke Maki <daisuke@endeworks.jp>

package DateTime::Calendar::Chinese;
use strict;
use warnings;
use vars qw($VERSION);
BEGIN
{
    $VERSION = '0.07';

    if ( $] >= 5.006 )
    {
        require utf8; utf8->import;
    }
}

use DateTime;
use DateTime::Event::Chinese;
use DateTime::Event::Lunar;
use DateTime::Event::SolarTerm;
use DateTime::Util::Astro::Common qw(MEAN_TROPICAL_YEAR);
use DateTime::Util::Astro::Moon qw(MEAN_SYNODIC_MONTH);
use DateTime::Util::Calc qw(moment dt_from_moment amod);
use Math::Round qw(round);
use Params::Validate();
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);

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[ amod( $_[0]->cycle_year, 10 ) - 1 ] }
sub terrestrial_branch { $terrestrial_branches[ amod( $_[0]->cycle_year, 12 ) - 1 ] }
sub year_name          { $_[0]->celestial_stem . $_[0]->terrestrial_branch }

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

sub zodiac_animal         { $zodiac_animals[ amod( $_[0]->cycle_year, 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 = DateTime::Event::Chinese->new_year_before(
        datetime     => 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 = DateTime::Event::Lunar->new_moon_after(
        datetime    => $p_dt,
#dt_from_moment( moment($new_year) + ($self->month - 1) * 29 ),
        on_or_after => 1
    );
    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 = DateTime::Event::Lunar->new_moon_after(
            datetime    => $p + DateTime::Duration->new(days => 1),
            on_or_after => 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');

    # last winter solstice
    my $s1 = DateTime::Event::SolarTerm->prev_term_at(
        datetime  => $dt,
        longitude => 270);

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

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

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

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

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

    # 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 =
        $m12_moment != $m_moment &&
        round((moment($next_m11) - $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 = amod(
        round( ($m_moment - $m12_moment) / MEAN_SYNODIC_MONTH) -
        (($leap_year && $self->_prior_leap_month($m12, $m)) ? 1 : 0), 12);

# XXX - debug stuff. nice to have when you're going "huh?"
#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: ", $leap_year ? "yes" : "no", "\n",
#    "m-m12: ",
#        round(abs($m_moment - $m12_moment) / MEAN_SYNODIC_MONTH), "\n",
#    "pleap: ", $self->_prior_leap_month($m12, $m) ? "yes" : "no", "\n",
#    "month: ", $month, "\n",
#    "<<<<<<\n";

    # 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} = amod($elapsed_years, 60);
    $self->{day}        = POSIX::ceil(moment($dt) - $m_moment + 1);

    $self->{leap_month} = ($leap_year &&
        DateTime::Event::SolarTerm->no_major_term_on(datetime => $m) &&
        !$self->_prior_leap_month($m12, DateTime::Event::Lunar->new_moon_before(datetime => $m))) ? 1 : 0;
}

sub elapsed_years
{
    my $self = shift;
    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 = shift;
    my($start, $end) = @_;

    return ($start <= $end) && (
        DateTime::Event::SolarTerm->no_major_term_on(datetime => $end) or
        $class->_prior_leap_month($start,
            DateTime::Event::Lunar->new_moon_before(datetime => $end) ) );
}

BEGIN
{
    if (eval { require Memoize } && !$@) {
        Memoize::memoize("_prior_leap_month", NORMALIZER => sub {
            join(".", ($_[0]->utc_rd_values)[0], ($_[1]->utc_rd_values)[0]);
        });
    }
}

1;
__END__