[kahua-dev:00753] カレンダー

[yasuyuki <yasuyuki@xxxxxxxxxxxx>]

えんどうです。

とりあえず月の移動ができるとろまでカレンダーを書いてみました。。
(srfi-19を使っているので、(allow-module srfi-19) を書いたプラグインが必要)

日付のところにリンクをつけるには、calendar 関数を
(define (calendar display-month proc) ...) みたいにして
proc を日付に適用させれば良いでしょうか。

;;-*-scheme-*-

(use util.list)
(use srfi-1)
(use srfi-19) ;; plugin

(define (firstday display-month) ;; 当月の1日
  (make-date 0 0 0 0 1 (ref display-month 'month) (ref display-month 'year) 0))

(define (prev-firstday display-month) ;; 先月の1日
  (let* ((this-month (ref display-month 'month))
	 (this-year  (ref display-month 'year))
	 (prev-month (if (> 2 this-month) 12 (- this-month 1)))
	 (prev-year  (if (> 2 this-month) (- this-year 1) this-year)))
    (make-date 0 0 0 0 1 prev-month prev-year 0)))

(define (next-firstday display-month) ;; 来月の1日
  (let* ((this-month (ref display-month 'month))
	 (this-year  (ref display-month 'year))
	 (next-month (if (> 12 this-month) (+ 1 this-month) 1))
	 (next-year  (if (> 12 this-month) this-year (+ 1 this-year))))
    (make-date 0 0 0 0 1 next-month next-year 0)))

(define (month-days display-month) ;; その月の日数
  (- (x->integer (truncate (date->julian-day (next-firstday display-month))))
     (x->integer (truncate (date->julian-day (firstday display-month))))))

(define (calendar-days display-month) ;; 月の先頭の曜日を埋める
  (append
   (make-list (date-week-day (firstday display-month)) "") ;; sun=0
   (map (cut + 1 <>) (iota (month-days display-month)))))

(define (calendar-list display-month) ;; 要素数7のリストのリスト
  (slices (calendar-days display-month) 7 #t ""))

(define (show-week week-list) ;; 週の td を得る
  (node-set
   (map (lambda (d) (td/ (@/ (align "right")) (x->string d))) week-list)))

(define (calendar display-month)
  (let* ((prev-month (prev-firstday display-month))
         (next-month (next-firstday display-month)))
    (table/
     (tr/ (td/ (@/ (colspan "2"))
               (a/cont/ (@@/ (cont (lambda () (calendar prev-month))))
                        (x->string (ref prev-month 'month)) "月"))
          (td/ (@/ (align "center") (colspan "3"))
              (x->string (ref display-month 'year)) "年"
              (x->string (ref display-month 'month)) "月")
          (td/ (@/ (align "right") (colspan "2"))
               (a/cont/ (@@/ (cont (lambda () (calendar next-month))))
                        (x->string (ref next-month 'month)) "月")))
     (tr/ (td/ (font/ (@/ (color "red")) "日")) (td/ "月") (td/ "火") (td/ "水")
          (td/ "木") (td/ "金") (td/ (font/ (@/ (color "blue")) "土")))
     (node-set
      (map (lambda (w) (tr/ (show-week w)))
           (calendar-list display-month))))))
  
(define (caltest)
  (html/ (head/ (title/ "test"))
         (body/ (calendar (current-date)))))

(initialize-main-proc caltest)


-- 
ENDO Yasuyuki <yasuyuki@xxxxxxxxxxxx>
http://www.javaopen.org/~yasuyuki/ (Persotal/Japanese Only)
http://www.javaopen.org/jfriends/ (Japanese Only)