WiLiKiにカレンダー

なんだかそろそろカレンダーを付けたくなってきた。まー普通にそのへんにあるかなぁ、とも思ったんやが、さしあたり現在公開されてるのがなさげやったんで作った。Gauche:CGI:スケジュール予定表とか参考にしつつ。

 [[$$calendar hogehoge]]

でhogehogeというprefixのカレンダーを表示。日付ページはhogehoge:yyyy/mm/ddという形式でリンクを貼って、無い日付は編集ページに貼ってある。Pukiwikiのプラグインっぽいのが欲しかったんで、そんな感じに。ついでにvirtual pageで過去や未来のカレンダー表示を実現。なんとなく寂しかったんでindexマクロを呼んで一覧も表示したり。

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

(define (calendar prefix year month today)
  (define (get-offset year month)
    (when (<= month 2) (dec! year) (inc! month 12))
    (modulo (+ year (quotient year 4)
		    (- (quotient year 100))
		    (quotient year 400)
		    (quotient (+ (* 13  month) 8) 5)
		    1)
	    7) )
  (define (get-length year month)
    (cond ((or (= month 4) (= month 6) (= month 9) (= month 11)) 30)
	  ((= month 2)
	   (if (and (zero? (modulo year 4))
		    (or (not (zero? (modulo year 100)))
			(zero? (modulo year 400))))
	     29
	     28))
	  (else 31)) )
  (define (print-day-link day weekday)
    (cond ((not day) "")
	  (else
	    (let ((key (format "~a:~4,'0d/~2,'0d/~2,'0d" prefix year month day)))
	      (if (wiliki-db-exists? key)
		`(a (@ (href ,(string-append "?" key))
		       (class ,(if (= today day) "calendar-today calendar-day" "calendar-day")))
		    ,(number->string day))
		`(a (@ (href ,(string-append "?" key "&c=e"))
		       (class ,(if (= today day) "calendar-today" "")))
		    ,(number->string day)))
	      ))
  ))
 
  (let ((table (slices (append (make-list (get-offset year month) #f)
			       (iota (get-length year month) 1))
		       7 #t) )
	(labels '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) )
    `(table (@ (class "calendar-table"))
       (tbody
	 (tr (td (a (@ (href ,(format "?Calendar:~a:~4,'0d/~2,'0d"
				      prefix
				      (if (= month 1) (- year 1) year)
				      (if (= month 1) 12 (- month 1)))))
		    "<<"))
	     (td (@ (colspan 5))
		 (a (@ (href ,(format "?Calendar:~a:~4,'0d/~2,'0d" prefix year month)))
		    ,(format "~a:~4,'0d/~2,'0d" prefix year month)))
	     (td (a (@ (href ,(format "?Calendar:~a:~4,'0d/~2,'0d"
				      prefix
				      (if (= month 12) (+ year 1) year)
				      (if (= month 12) 1 (+ month 1)))))
		    ">>")))
	 (tr ,@(map (lambda (x) `(th ,x)) labels))
	 ,@(map (lambda (line)
		  `(tr ,@(map (lambda (item) `(td ,(print-day-link item 0)))
			      line)) )
		table)
	 ))
    ))

(define (today-calendar prefix)
  (let ((today (current-date)))
	(calendar prefix (date-year today) (date-month today) (date-day today))))


(define-reader-macro (calendar prefix)
 `(,(today-calendar prefix)) )

(define-virtual-page (#/^Calendar:([^:]+).*$/ (query))
  (rxmatch-let
    (#/^Calendar:([^:]+)(:([0-9]+)(\/([0-9]+))?)?$/ query)
    (_ prefix _ syear _ smonth)
    (let* ((date (current-date))
	   (year (if syear (string->number syear) (date-year date)))
	   (month (if smonth (string->number smonth) (date-month date))))
      `(,(calendar prefix 
		   year
		   month
		   (if (and (= year (date-year date))
			    (= month (date-month date)))
		     (date-day date)
		     0))
	 ,@(handle-reader-macro (format "$$index ~a:~4,'0d/~2,'0d" prefix year month))))
   ))

似たようなコードが散乱してて見苦しいけど気にしない。これをcal.scmとかにして、wiliki/macro.scmで (load "wiliki/cal.scm") として読み込んだりして運用中。