ドキュメントはまだない。
基本的にはGauche:CGI:スケジュール予定表から構築してるが、 返りを日付を表す数値のリストではなくdate型のリストとかを使っている点で汎用性を持っているつもり。
無駄なアルゴリズムを使っていると思われるものもあるが、 ごまかそうとすると誤差が出て来たりしてハマるので実にナイーブな実装をしている。8-(
(define-module calendar.calendar
(use srfi-1)
(use srfi-19)
(use util.list)
(export make-date-lite make-month-lite make-year-lite today
current-month prev-month next-month
days-of-month first-date-of-month last-date-of-month
same-date? same-month? same-year? include?
dates-of-month date-slices-of-month
dates-of-week current-week prev-week next-week
nth-week-before nth-week-after
current-day prev-day next-day nth-day-before nth-day-after
yesterday tomorrow
current-year prev-year next-year
date=? date<? date<=? date>? date>=?
)
)
(select-module calendar.calendar)
(define (inc n) (+ n 1))
(define (dec n) (- n 1))
(define (mask pred? item ilst)
(map (lambda (i)
(if (pred? i item) i #f))
ilst))
(define (include? item ilst pred?)
(if (null? ilst) #f
(if (pred? item (car ilst)) #t
(include? item (cdr ilst) pred?))))
(define (make-date-lite y m d)
(make-date 0 0 0 0 d m y (date-zone-offset (current-date))))
(define (make-month-lite y m)
(make-date 0 0 0 0 1 m y (date-zone-offset (current-date))))
(define (make-year-lite y)
(make-date 0 0 0 0 1 1 y (date-zone-offset (current-date))))
(define (today)
(let1 d (current-date)
(make-date-lite (date-year d) (date-month d) (date-day d))))
(define (current-month date)
(make-month-lite (date-year date) (date-month date)))
(define (prev-month date)
(if (= (date-month date) 1)
(make-month-lite (dec (date-year date)) 12)
(make-month-lite (date-year date) (dec (date-month date)))))
(define (next-month date)
(if (= (date-month date) 12)
(make-month-lite (inc (date-year date)) 1)
(make-month-lite (date-year date) (inc (date-month date)))))
(define (days-of-month date)
(inexact->exact
(- (date->modified-julian-day (next-month date))
(date->modified-julian-day (current-month date)))))
(define (first-date-of-month date)
(make-date-lite (date-year date) (date-month date) 1))
(define (last-date-of-month date)
(make-date-lite (date-year date) (date-month date) (days-of-month date)))
(define (same-date? d1 d2)
(and (and (date? d1) (date? d2))
(= (date-day d1) (date-day d2))
(= (date-month d1) (date-month d2))
(= (date-year d1) (date-year d2))))
(define (same-month? d1 d2)
(and (and (date? d1) (date? d2))
(= (date-month d1) (date-month d2))
(= (date-year d1) (date-year d2))))
(define (same-year? d1 d2)
(and (and (date? d1) (date? d2))
(= (date-year d1) (date-year d2))))
(define (dates-of-month date)
(let ((y (date-year date))
(m (date-month date)))
(map (lambda (d)
(make-date-lite y m d))
(iota (days-of-month date) 1))))
(define (date-slices-of-month date . flag)
(let1 flag (get-optional flag #f)
(let* ((cday1 date)
(pday1 (prev-month date))
(cmonth (dates-of-month date))
(pmonth (dates-of-month (prev-month date)))
(nmonth (dates-of-month (next-month date))))
(let1 pcn (slices (append (make-list (date-week-day pday1) #f)
pmonth cmonth nmonth)
7 #t #f)
(let rec ((pcn pcn)
(cal '()))
(if (null? pcn)
(if flag (reverse cal)
(map (lambda (w)
(mask same-month? date w))
(reverse cal)))
(if (include? date (car pcn) same-month?)
(rec (cdr pcn) (cons (car pcn) cal))
(rec (cdr pcn) cal))))))))
(define (dates-of-week date . flag)
(let1 flag (get-optional flag #f)
(let* ((wd (date-week-day date))
(sunday (nth-day-before wd date)))
(let rec ((week '())
(day sunday)
(n 7))
(if (= n 0)
(if flag (reverse week)
(mask same-month? date (reverse week)))
(rec (cons day week) (next-day day) (dec n)))))))
(define current-week dates-of-week)
(define (prev-week date . flag)
(let1 flag (get-optional flag #f)
(let* ((wd (date-week-day date))
(saturday (nth-day-before (+ wd 1) date)))
(let rec ((week '())
(day saturday)
(n 7))
(if (= n 0)
(if flag week
(mask same-month? date week))
(rec (cons day week) (prev-day day) (dec n)))))))
(define (next-week date . flag)
(let1 flag (get-optional flag #f)
(let* ((wd (date-week-day date))
(sunday (nth-day-after (- 7 wd) date)))
(let rec ((week '())
(day sunday)
(n 7))
(if (= n 0)
(if flag (reverse week)
(mask same-month? date (reverse week)))
(rec (cons day week) (next-day day) (dec n)))))))
(define (current-day date)
(make-date-lite (date-year date) (date-month date) (date-day date)))
(define (prev-day date)
(if (same-date? date
(first-date-of-month date))
(last-date-of-month (prev-month date))
(make-date-lite (date-year date)
(date-month date)
(dec (date-day date)))))
(define (next-day date)
(if (same-date? date
(last-date-of-month date))
(first-date-of-month (next-month date))
(make-date-lite (date-year date)
(date-month date)
(inc (date-day date)))))
(define (nth-day-before n date)
(if (= n 0) date (nth-day-before (dec n) (prev-day date))))
(define (nth-day-after n date)
(if (= n 0) date (nth-day-after (dec n) (next-day date))))
(define (nth-week-before n date . flag)
(let1 flag (get-optional flag #f)
(if (= n 0)
(current-week date flag)
(nth-week-before (dec n) (car (prev-week date #t)) flag))))
(define (nth-week-after n date . flag)
(let1 flag (get-optional flag #f)
(if (= n 0)
(current-week date flag)
(nth-week-after (dec n) (car (next-week date #t)) flag))))
(define (yesterday) (prev-day (today)))
(define (tomorrow) (next-day (today)))
(define (current-year date)
(make-year-lite (date-year date)))
(define (prev-year date)
(make-year-lite (dec (date-year date))))
(define (next-year date)
(make-year-lite (inc (date-year date))))
(define (date=? . args)
(apply = (map date->modified-julian-day args)))
(define (date<? . args)
(apply < (map date->modified-julian-day args)))
(define (date<=? . args)
(apply <= (map date->modified-julian-day args)))
(define (date>? . args)
(apply > (map date->modified-julian-day args)))
(define (date>=? . args)
(apply >= (map date->modified-julian-day args)))
(provide "calendar.calendar")
;; Local variables:
;; mode: scheme
;; end:
(use gauche.test)
(test-start "calendar")
(use srfi-1)
(use srfi-19)
(use calendar.calendar)
(test-module 'calendar.calendar)
(test-section "calendar.calendar")
(test* "calendar mask 1" '(0 1 2 3 4 #f #f #f #f #f)
(with-module calendar.calendar
(mask <= 4 (iota 10))))
(test* "calendar mask 2" '(0 #f 2 #f 4 #f 6 #f 8 #f)
(with-module calendar.calendar
(mask (lambda (a b)
(even? a))
"No Care" (iota 10))))
(test* "calendar include? 1" #t
(with-module calendar.calendar
(include? 100 (iota 10) >=)))
(test* "calendar include? 2" #f
(with-module calendar.calendar
(include? -100 (iota 10) >=)))
(test* "calendar make-date-lite 1" #t
(date? (make-date-lite 2005 1 1)))
(test* "calendar make-date-lite 2" '(2005 1 1)
(let1 day (make-date-lite 2005 1 1)
(list (date-year day) (date-month day) (date-day day))))
(test* "calendar make-month-lite 1" '(2005 1 1)
(let1 day (make-month-lite 2005 1)
(list (date-year day) (date-month day) (date-day day))))
(test* "calendar make-year-lite 1" '(2005 1 1)
(let1 day (make-year-lite 2005)
(list (date-year day) (date-month day) (date-day day))))
(test* "calendar current-month 1" '(2005 1 1)
(let1 day (current-month (make-date-lite 2005 1 31))
(list (date-year day) (date-month day) (date-day day))))
(test* "calendar prev-month 1" '(2004 12 1)
(let1 day (prev-month (make-date-lite 2005 1 31))
(list (date-year day) (date-month day) (date-day day))))
(test* "calendar next-month 1" '(2005 1 1)
(let1 day (next-month (make-date-lite 2004 12 31))
(list (date-year day) (date-month day) (date-day day))))
(test* "calendar days-of-month 1" '(31 28 31 30 31 30 31 31 30 31 30 31)
(map days-of-month
(map (lambda (m) (make-date-lite 2005 m 1)) (iota 12 1))))
(test* "calendar days-of-month 2" '(31 29 31 30 31 30 31 31 30 31 30 31)
(map days-of-month
(map (lambda (m) (make-date-lite 2000 m 1)) (iota 12 1))))
(test* "calendar first-date-of-month 1" '(2005 1 1)
(let1 day (first-date-of-month (make-date-lite 2005 1 31))
(list (date-year day) (date-month day) (date-day day))))
(test* "calendar last-date-of-month 1" '(31 28 31 30 31 30 31 31 30 31 30 31)
(map date-day
(map last-date-of-month
(map (lambda (m) (make-date-lite 2005 m 1)) (iota 12 1)))))
(test* "calendar same-date? 1" #t
(same-date? (make-date-lite 2005 1 1) (make-date-lite 2005 1 1)))
(test* "calendar same-date? 2" #f
(same-date? (make-date-lite 2004 12 31) (make-date-lite 2005 1 1)))
(test* "calendar same-month? 1" #t
(same-month? (make-date-lite 2005 1 1) (make-date-lite 2005 1 31)))
(test* "calendar same-month? 2" #f
(same-month? (make-date-lite 2004 12 31) (make-date-lite 2005 1 1)))
(test* "calendar same-year? 1" #t
(same-year? (make-date-lite 2005 1 1) (make-date-lite 2005 12 31)))
(test* "calendar same-year? 2" #f
(same-year? (make-date-lite 2004 12 31) (make-date-lite 2005 1 1)))
(test* "calendar dates-of-month 1" (make-list 31 #t)
(map (lambda (d) (same-month? d (make-date-lite 2005 1 15)))
(dates-of-month (make-date-lite 2005 1 1))))
(test* "calendar date-slices-of-month 1" (make-list 6 #t)
(map (lambda (w) (include? (make-date-lite 2005 1 15) w same-month?))
(date-slices-of-month (make-date-lite 2005 1 1))))
(test* "calendar date-slices-of-month 2" (make-list 6 #t)
(map (lambda (w) (every date? w))
(date-slices-of-month (make-date-lite 2005 1 1) #t)))
(test* "calendar dates-of-week 1" (iota 7)
(map date-week-day
(dates-of-week (make-date-lite 2005 1 1) #t)))
(test* "calendar dates-of-week 2" (append (iota 6 26) '(1))
(map date-day
(dates-of-week (make-date-lite 2005 1 1) #t)))
(test* "calendar dates-of-week 3" (iota 7)
(map date-week-day
(dates-of-week (make-date-lite 2005 1 15))))
(test* "calendar dates-of-week 4" (iota 7 9)
(map date-day
(dates-of-week (make-date-lite 2005 1 15))))
(test* "calendar current-week 1" #t
(eq? current-week dates-of-week))
(test* "calendar prev-week 1" (make-list 7 #t)
(map same-date?
(prev-week (make-date-lite 2005 1 1) #t)
(current-week (make-date-lite 2004 12 20))))
(test* "calendar next-week 1" (make-list 7 #t)
(map same-date?
(next-week (make-date-lite 2004 12 31) #t)
(current-week (make-date-lite 2005 1 5))))
(test* "calendar current-day 1" #t
(same-date? (current-day (make-date-lite 2005 1 1))
(make-date-lite 2005 1 1)))
(test* "calendar prev-day 1" #t
(same-date? (make-date-lite 2004 12 31)
(prev-day (make-date-lite 2005 1 1))))
(test* "calendar prev-day 2" #t
(same-date? (make-date-lite 2005 2 28)
(prev-day (make-date-lite 2005 3 1))))
(test* "calendar next-day 1" #t
(same-date? (make-date-lite 2005 1 1)
(next-day (make-date-lite 2004 12 31))))
(test* "calendar next-day 2" #t
(same-date? (make-date-lite 2005 3 1)
(next-day (make-date-lite 2005 2 28))))
(test* "calendar nth-day-before 1" #t
(same-date? (make-date-lite 2005 2 25)
(nth-day-before 10 (make-date-lite 2005 3 7))))
(test* "calendar nth-day-before 2" #t
(same-date? (make-date-lite 2004 12 25)
(nth-day-before 10 (make-date-lite 2005 1 4))))
(test* "calendar nth-day-after 1" #t
(same-date? (make-date-lite 2005 1 4)
(nth-day-after 10 (make-date-lite 2004 12 25))))
(test* "calendar nth-day-after 2" #t
(same-date? (make-date-lite 2005 3 7)
(nth-day-after 10 (make-date-lite 2005 2 25))))
(test* "calendar current-year 1" #t
(same-date? (make-date-lite 2005 1 1)
(current-year (make-date-lite 2005 12 31))))
(test* "calendar prev-year 1" #t
(same-date? (make-date-lite 2004 1 1)
(prev-year (make-date-lite 2005 12 31))))
(test* "calendar next-year 1" #t
(same-date? (make-date-lite 2006 1 1)
(next-year (make-date-lite 2005 12 31))))
(test* "calendar date=? 1" #t
(date=? (make-date-lite 2004 12 31)
(make-date-lite 2004 12 31)
(make-date-lite 2004 12 31)
(make-date-lite 2004 12 31)
(make-date-lite 2004 12 31)))
(test* "calendar date=? 2" #f
(date=? (make-date-lite 2004 12 31)
(make-date-lite 2004 12 31)
(make-date-lite 2005 1 1)
(make-date-lite 2004 12 31)
(make-date-lite 2004 12 31)))
(test* "calendar date<? 1" #t
(date<? (make-date-lite 2004 12 29)
(make-date-lite 2004 12 30)
(make-date-lite 2004 12 31)
(make-date-lite 2005 1 1)
(make-date-lite 2005 1 2)))
(test* "calendar date<? 2" #f
(date<? (make-date-lite 2004 12 29)
(make-date-lite 2004 12 30)
(make-date-lite 2004 12 30)
(make-date-lite 2005 1 1)
(make-date-lite 2005 1 2)))
(test* "calendar date<=? 1" #t
(date<=? (make-date-lite 2004 12 29)
(make-date-lite 2004 12 29)
(make-date-lite 2004 12 31)
(make-date-lite 2005 1 2)
(make-date-lite 2005 1 2)))
(test* "calendar date<=? 2" #f
(date<=? (make-date-lite 2004 12 29)
(make-date-lite 2005 1 1)
(make-date-lite 2004 12 30)
(make-date-lite 2004 12 30)
(make-date-lite 2005 1 2)))
(test* "calendar date>? 1" #t
(date>? (make-date-lite 2005 1 2)
(make-date-lite 2005 1 1)
(make-date-lite 2004 12 31)
(make-date-lite 2004 12 30)
(make-date-lite 2004 12 29)))
(test* "calendar date>? 2" #f
(date>? (make-date-lite 2005 1 2)
(make-date-lite 2005 1 1)
(make-date-lite 2004 12 30)
(make-date-lite 2004 12 30)
(make-date-lite 2004 12 29)))
(test* "calendar date>=? 1" #t
(date>=? (make-date-lite 2005 1 2)
(make-date-lite 2005 1 2)
(make-date-lite 2004 12 31)
(make-date-lite 2004 12 29)
(make-date-lite 2004 12 29)))
(test* "calendar date>=? 2" #f
(date>=? (make-date-lite 2005 1 2)
(make-date-lite 2004 12 30)
(make-date-lite 2004 12 30)
(make-date-lite 2005 1 1)
(make-date-lite 2004 12 29)))
(test-end)
;; Local variables:
;; mode: scheme
;; end:
(define-module calendar.holiday
(use srfi-19)
(extend calendar.calendar)
(export holiday?
)
)
(select-module calendar.holiday)
(define holy-day (make-date-lite 1948 7 20))
(define compensating-holiday (make-date-lite 1973 4 12))
#|
(define (make-date-pred pred)
(lambda (d1 d2)
(pred (date->modified-julian-day d1)
(date->modified-julian-day d2))))
(define-values
(date=? date<? date<=? date>? date>=?)
(values
(make-date-pred =)
(make-date-pred <)
(make-date-pred <=)
(make-date-pred >)
(make-date-pred >=)))
|#
(define int floor)
(define (make-equinox p1979 p2099 p2150)
(define max-day 99)
(lambda (yy)
(let ((v1 (* 0.242194 (- yy 1980)))
(v2 (int (/ (- yy 1983) 4)))
(v3 (int (/ (- yy 1980) 4))))
(cond ((<= yy 1947) max-day)
((<= yy 1979) (- (int (+ p1979 v1)) v2))
((<= yy 2099) (- (int (+ p2099 v1)) v3))
((<= yy 2150) (- (int (+ p2150 v1)) v3))
(else max-day)))))
(define spring-equinox (make-equinox 20.8357 20.8431 21.851))
(define autumnal-equinox (make-equinox 23.2588 23.2488 24.2488))
(define (holiday? t)
(define %workday 0)
(define %saturday 1)
(define %sunday 2)
(define %holiday 3)
(define %compensate 4)
(define %holy 5)
(define (prev-day d)
(modified-julian-day->date
(- (date->modified-julian-day d) 1.0)))
(let ((yy (date-year t))
(mm (date-month t))
(dd (date-day t))
(ww (date-week-day t)))
(let1 r %workday
(define (set-holy!) (set! r %holy))
(define (set-holiday!) (set! r %holiday))
(case ww
((6) (set! r %saturday))
((0) (set! r %sunday)))
(if (date<? t holy-day) r
(case mm
((1) (case dd
((1) (set-holy!))
(else (if (>= yy 2000)
(if (= (int (/ (- dd 1) 7)) ww 1)
(set-holy!))
(if (= dd 15) (set-holy!))))))
((2) (case dd
((11) (if (>= yy 1967) (set-holy!)))
((24) (if (= yy 1989) (set-holy!)))))
((3) (if (= dd (spring-equinox yy))
(set-holy!)))
((4) (case dd
((29) (set-holy!))
((10) (if (= yy 1959) (set-holy!)))))
((5) (case dd
((3) (set-holy!))
((4) (if (and (> ww 1) (>= yy 1986))
(set-holiday!)))
((5) (set-holy!))))
((6) (if (and (= yy 1993) (= dd 9))
(set-holy!)))
((7) (cond ((>= yy 2003)
(if (and (= (int (/ (- dd 1) 7)) 2) (= ww 1))
(set-holy!)))
((>= yy 1996)
(if (= dd 20) (set-holy!)))))
((9) (if (= dd (autumnal-equinox yy))
(set-holy!)
(cond ((>= yy 2003)
(if (and (= (int (/ (- dd 1) 7)) 2) (= ww 1))
(set-holy!)
(if (and (= ww 2)
(= dd (- (autumnal-equinox yy) 1)))
(set-holiday!))))
((>= yy 1966) (if (= dd 15) (set-holy!))))))
((10) (cond ((>= yy 2000) (if (= (int (/ (- dd 1) 7)) ww 1)
(set-holy!)))
((>= yy 1966) (if (= dd 10) (set-holy!)))))
((11) (case dd
((3 23) (set-holy!))
((12) (if (= yy 1990) (set-holy!)))))
((12) (case dd
((23) (if (>= yy 1989) (set-holy!)))))))
(if (and (<= r %holiday) (= ww 1))
(if (date>=? t compensating-holiday)
(if (= (holiday? (prev-day t)) %holy)
%compensate)))
r)))
(provide "calendar.holiday")
;; Local variables:
;; mode: scheme
;; end:
たとえばロードパスはこいつを追加
GAUCHE_LOAD_PATH=/home/cut-sea/lib/Gauche:${GAUCHE_LOAD_PATH}
さらに
cut-sea@nkisi> pwd /usr/home/cut-sea/lib/Gauche/calendar
なんてcalendarディレクトリを掘って、
cut-sea@nkisi> ll total 38 -r--r--r-- 1 cut-sea users 6213 Jul 28 11:01 calendar.scm -r--r--r-- 1 cut-sea users 4049 Jul 28 11:02 holiday.scm -r--r--r-- 1 cut-sea users 8090 Jul 28 11:03 test-calendar.scm
こんな風に専用に配置すればOK。
こっから下は後々整理します。
gosh> (map holiday? (map (lambda (d) (make-date-lite 2005 1 d)) (iota 31 1))) (5 2 0 0 0 0 0 1 2 5 0 0 0 0 1 2 0 0 0 0 0 1 2 0 0 0 0 0 1 2 0) gosh> (map holiday? (map (lambda (d) (make-date-lite 2005 4 d)) (iota 30 1))) (0 1 2 0 0 0 0 0 1 2 0 0 0 0 0 1 2 0 0 0 0 0 1 2 0 0 0 0 5 1)
アルゴリズムは上記参照サイトを見てまるまる持ち込んだ。
代入を多用しているのが不細工だけど、いじると無駄にバグバグしそうだったんで。
なお返り値はコードに埋め込まれている通り。
(define %workday 0) ;;平日 (define %saturday 1) ;;土曜 (define %sunday 2) ;;日曜 (define %holiday 3) ;;休日 (define %compensate 4) ;;振替 (define %holy 5) ;;祝日
という扱いだ。 ここで注意点としては返り値をいじりたかったら、 holiday?をラップするようにするのが一番簡単でそうするのが推奨。 最後の振替休日を計算するところで(<= r %holiday)という計算があるからだ。 こういうのは
(case r ((%workday %saturday %sunday %holiday) ...) (else ...))
みたいにするのが効率は別にして正しい感じがするが。
ちなみに大喪の礼だのなんだの、そういうちょっと特殊な日も入っているらしい。
あとカレンダーの作りに関して言えば、スケジュール予定表では
もともとがquick hack前提だったのであれで良かった。
でも、できるだけdateオブジェクトでリスト処理しつつ、
html出力寸前で抽出+書式整形する方が応用がききやすいと思ったことがある。
例えばカレンダー表示自体でも隣接月の日付を薄い文字で表示する様なタイプのものが
あるけど、そういうのはやっぱりdateでリストにしておいた方が便利だった。
そうして生成したカレンダーの素になるリストにholiday?を当てるような使い方をする。
cut-sea:2005/04/09 09:27:17 PDT
うーん。返り値から見るとholiday?ってのは、ちとミスリーディングだな。cut-sea
あ、int は x->integer ではダメで floor でした。 2009/9とか2010/9の休日判定でミスがでる。cut-sea:2005/04/09 18:19:14 PDT