;; History: 2005-05-07 14:06:40 << 2005-05-04 11:37:59

(define-plugin "calendar"
  (version "0.1")
  (export make-calendar)
  (depend #f))

#| Ref.

http://www.shiro.dreamhost.com/scheme/wiliki/wiliki.cgi?Gauche%3aCGI%3a%a5%b9%a5%b1%a5%b8%a5%e5%a1%bc%a5%eb%cd%bd%c4%ea%c9%bd%3aShiro%c8%c7
http://www.kahua.org/mlarchive/kahua-dev/msg00752.html

Usage:

(make-calendar 2005 5 (lambda (y m d w) (number->string d)))

|#

(use srfi-1)
(use util.list)
(use srfi-19)
(use kahua.elem)

;; make-calendar-day: for example, (lambda (y m d) (number->string d))
(define-export (make-calendar y m make-calendar-day . calendar-header)
  (apply %make-calendar y m make-calendar-day calendar-header))

;; 0 (Sunday) or 1 (Monday)
(define week-start 0)

(define zone-offset 32400)

;; ============================================

(define (%make-calendar y m make-calendar-day . calendar-header)
  (table:
   (@: (class "calendar"))
   (get-optional calendar-header '())
   (tr: (node-list-to-node-set
         (map (lambda (d) (td: (@: (class (car d))) (cdr d)))
              (make-weekdays))))
   (node-list-to-node-set
    (map (lambda (week)
           (tr: (node-list-to-node-set
                 (let1 wday 0
                   (map (lambda (day)
                          (begin0
                            (td: (@: (class "calendar-day"))
                                 (if day
                                   (make-calendar-day y m day wday)
                                   ""))
                            (inc! wday)))
                        week)))))
         (make-list-calendar y m)))))

(define (make-weekdays)
  (let1 days '((calendar-sunday   . "Sun") (calendar-weekday  . "Mon")
               (calendar-weekday  . "Tue") (calendar-weekday  . "Wed")
               (calendar-weekday  . "Thu") (calendar-weekday  . "Fri")
               (calendar-saturday . "Sat"))
    (append (drop days week-start) (take days week-start))))

(define (make-list-calendar y m)
  (slices
   (append
    (make-list (modulo (- (week-day-of-first-day y m) week-start) 7)
               #f)
    (iota (last-day-of y m) 1))
   7 #t #f))

(define (last-day-of y m)
  (date-day (julian-day->date
             (- (date->julian-day (make-date 0 0 0 0 1
                                             (+ m 1) y zone-offset))
                1))))

(define (week-day-of-first-day y m)
  (date-week-day (make-date 0 0 0 0 1 m y zone-offset)))