;; History: 2005-05-04 12:17:12 << 2005-05-04 11:31:59

(define-plugin "holiday-jp"
  (version "0.1")
  (export holidays-on-date)
  (depend #f))

(use srfi-1)
(use srfi-19)

(define-export (holidays-on-date y m d)
  ;; y 年 m 月 d 日の祝日のリストをかえす。何も祝日が無ければ、空リストをかえす。
  ;; かえり値は、("内容" ... )
  (%holidays-on-date-body y m d))

(define holidays-list '())
;; 祝日のリスト。
;; (("内容" . finder) ... )
;; の形式。
;; finder は、
;;  リスト (month day) か、
;;  year month day を引数にとり、year 年 month 月 day 日がその祝日であれば #t を、
;;  そうでなければ #f をかえす手続き。

(define zone-offset 0)

(define (%make-date year month day)
  ;; year month day から <date> を作成する。
  (make-date 0 0 0 0 day month year zone-offset))

(define (yesterday date . nth)
  ;; date の前日を <date> クラスでかえす。
  (julian-day->date (- (date->julian-day date)
                       (get-optional nth 1))))

(define-method nth-week-day? ((date <date>) wday nth)
  ;; date が nth 番目の wday 曜日であるか。
  ;; wday は、日曜日が 0、月曜日が 1 など。
  ;; nth は 0 から数える。
  (and (= (date-week-day date) wday)
       (= nth (- (ceiling (/ (date-day date) 7)) 1))))

(define-method nth-week-day? (year month day wday nth)
  ;; nth 番目の wday 曜日であるか。
  ;; wday は、日曜日が 0、月曜日が 1 など。
  ;; nth は 0 から数える。
  (nth-week-day? (%make-date year month day) wday nth))

(define (nth-week-day year month wday nth)
  ;; year month の nth 番目の wday 曜日が何日であるかをかえす。
  ;; wday は、日曜日が 0、月曜日が 1 など。
  ;; nth は 0 から数える。
  (let1 sw (date-week-day (%make-date year month 1))
    (+ (- (* (+ 1 nth) 7) sw) 1 wday (if (< wday sw) 0 -7))))

(define-method week-day-of (year month day)
  ;; year month day が何曜日であるかをかえす。
  ;; wday は、日曜日が 0、月曜日が 1 など。
  (date-week-day (%make-date year month day)))

(define-method week-day-of ((date <date>))
  ;; date が何曜日であるかをかえす。
  ;; wday は、日曜日が 0、月曜日が 1 など。
  (date-week-day day))

(define (%holidays-on-date-body y m d)
  ;; y 年 m 月 d 日の祝日リストをかえす。何も祝日が無ければ、空リストをかえす。
  (filter-map
   (lambda (holiday)
     (let ((name (car holiday))
           (holiday? (cdr holiday)))
       (and (if (procedure? holiday?)
              (holiday? y m d)
              (and (= m (car  holiday?))
                   (= d (cadr holiday?))))
            name)))
   holidays-list))

(define (%holidays-on-date date)
  ;; (date <date>) の祝日のリストをかえす。何も祝日が無ければ、空リストをかえす。
  ;; かえり値は、("内容" ... )
  (%holidays-on-date-body (date-year date)
                          (date-month date)
                          (date-day date)))

;; ==============================================
;; Holidays in Japan

(define zone-offset 32400)

(define (national-holiday? y m d)
  (cond ((and (= m 5) (= d 4)))
        ((= m 9)
         (and (not (null? (%holidays-on-date (yesterday (%make-date y m d)))))
              (not (null? (%holidays-on-date (yesterday (%make-date y m d) -1))))))
        (else #f)))

(define (vernal-equinox-day? y m d)
  (and (= m 3)
       (= d (simple-calc-vernal-equinox y))))

(define (autumnal-equinox-day? y m d)
  (and (= m 3)
       (= d (simple-calc-autumnal-equinox y))))

(define (simple-calc-vernal-equinox y)
  ;; http://www.h3.dion.ne.jp/~sakatsu/holiday_topic.htm
  (define (calc const)
    (inexact->exact
     (floor (+ const (* 0.242194 (- y 1980))
               (- (floor (/ (- y 1980) 4)))))))
  (cond ((and (<  1850 y) (< y 1900))
         (calc 19.8277))
        ((and (<= 1900 y) (< y 1980))
         (calc 20.8357))
        ((and (<= 1980 y) (< y 2100))
         (calc 20.8431))
        ((and (<= 2100 y) (<= y 2150))
         (calc 21.8510))
        (else 20)))

(define (simple-calc-autumnal-equinox y)
  ;; http://www.h3.dion.ne.jp/~sakatsu/holiday_topic.htm
  (define (calc const)
    (inexact->exact
     (floor (+ const (* 0.242194 (- y 1980))
               (- (floor (/ (- y 1980) 4)))))))
  (cond ((and (<  1850 y) (< y 1900))
         (calc 22.2588))
        ((and (<= 1900 y) (< y 1980))
         (calc 23.2588))
        ((and (<= 1980 y) (< y 2100))
         (calc 23.2488))
        ((and (<= 2100 y) (<= y 2150))
         (calc 24.2488))
        (else 23)))

(set! holidays-list
      (list '("元旦" 1  1)
            (cons "成人の日"
                  (lambda (y m d)
                    (if (= m 1)
                      (= d (if (<= y 2000) 15 (nth-week-day 2 1 y m)))
                      #f)))
            '("建国記念の日" 2 11)
            '("みどりの日" 4 29)
            '("憲法記念日" 5 3)
            '("こどもの日" 5 5)
            '("海の日" 7 20)
            (cons "敬老の日"
                  (lambda (y m d)
                    (if (= m 9)
                      (= d (if (<= y 2003) 15 (nth-week-day 3 1 y m)))
                      #f)))
            (cons "体育の日"
                  (lambda (y m d)
                    (if (= m 10)
                      (= d (if (<= y 2000) 10 (nth-week-day 2 1 y m)))
                      #f)))
            '("文化の日" 11 3)
            '("勤労感謝の日" 11 23)
            '("天皇誕生日" 12 23)
            (cons "振替休日"
                  (lambda (y m d)
                    (and (= 1 (week-day-of y m d))
                         (not (null? (%holidays-on-date
                                      (yesterday (%make-date y m d))))))))
            (cons "国民の休日" national-holiday?)
            (cons "春分の日" vernal-equinox-day?)
            (cons "秋分の日" autumnal-equinox-day?)))