;;; -*- Mode: Lisp; Package: EDITOR -*-
;;;
;;; This file is part of xyzzy.
;;;

(provide "calendar")

(in-package "editor")

(export '(calendar calendar-mode *calendar-mode-hook* *calendar-mode-map*
	  calendar-next-page-or-year calendar-previous-page-or-year
	  calendar-mouse-popup calendar-popup))

(defvar *calendar-gregorian-reform-year* 1582)
(defvar *calendar-gregorian-reform-month* 10)
(defvar *calendar-gregorian-reform-day* 15)

(defvar *calendar-equinox-parameter-list*
  '((1850)
    (1899 1983 19.8277 22.2588)
    (1979 1983 20.8357 23.2588)
    (2099 1980 20.8431 23.2488)
    (2150 1980 21.8510 24.2488)))

(defvar *calendar-last-day-of-month*
  #(0 31 28 31 30 31 30 31 31 30 31 30 31))

(defvar *calendar-japanese-holiday-list*
  '(
    ;1873(明治6)年10月15日 太政官布告344号
    (1874 1912 1 3 "元始祭")
    (1874 1912 1 5 "新年宴會")
    (1874 1912 1 30 "孝明天皇祭")
    (1874 1912 2 11 "紀元節")
    (1874 1912 4 3 "神武天皇祭")
    (1874 1878 9 17 "神嘗祭")
    (1873 1911 11 3 "天長節")
    (1873 1911 11 23 "新嘗祭")
    ;1878(明治11)年6月5日 太政官布告23号
    (1879 1912 3 calendar-vernal-equinox "春季皇靈祭")
    (1878 1911 9 calendar-autumnal-equinox "秋季皇靈祭")
    ;1879(明治12)年7月5日 太政官布告27号
    (1879 1911 10 17 "神嘗祭")
    ;1912(大正元)年9月3日 勅令19号 (即日施行)
    (1913 1927 1 3 "元始祭")
    (1913 1927 1 5 "新年宴會")
    (1913 1927 2 11 "紀元節")
    (1913 1926 3 calendar-vernal-equinox "春季皇靈祭")
    (1913 1926 4 3 "神武天皇祭")
    (1913 1926 7 30 "明治天皇祭")
    (1913 1926 8 31 "天長節")
    (1912 1926 9 calendar-autumnal-equinox "秋季皇靈祭")
    (1912 1926 10 17 "神嘗祭")
    (1912 1926 11 23 "新嘗祭")
    ;1913(大正2)年7月16日 勅令259号
    (1913 1926 10 31 "天長節祝日")
    ;1915(大正4)年9月21日 勅令161号
    (1915 1915 11 10 "即位ノ禮")
    (1915 1915 11 14 "大嘗祭")
    (1915 1915 11 16 "即位禮及大嘗祭後大饗第一日")
    ;1927(昭和2)年3月3日 勅令25号 (即日施行)
    (1928 1948 1 3 "元始祭")
    (1928 1948 1 5 "新年宴會")
    (1928 1948 2 11 "紀元節")
    (1927 1948 3 calendar-vernal-equinox "春季皇靈祭")
    (1927 1948 4 3 "神武天皇祭")
    (1927 1948 4 29 "天長節")
    (1927 1947 9 calendar-autumnal-equinox "秋季皇靈祭")
    (1927 1947 10 17 "神嘗祭")
    (1927 1947 11 3 "明治節")
    (1927 1947 11 23 "新嘗祭")
    (1927 1947 12 25 "大正天皇祭")
    ;1928(昭和3)年9月8日 勅令226号 
    (1928 1928 11 10 "即位ノ禮")
    (1928 1928 11 14 "大嘗祭")
    (1928 1928 11 16 "即位禮及大嘗祭後大饗第一日")
    ;1948(昭和23)年7月20日 法律第178号 (即日施行)
    (1949 nil 1 1 "元日")
    (1949 1999 1 15 "成人の日")
    (1949 nil 3 calendar-vernal-equinox "春分の日")
    (1949 1988 4 29 "天皇誕生日")
    (1949 nil 5 3 "憲法記念日")
    (1949 nil 5 5 "こどもの日")
    (1948 nil 9 calendar-autumnal-equinox "秋分の日")
    (1948 nil 11 3 "文化の日")
    (1948 nil 11 23 "勤労感謝の日")
    ;1959(昭和34)年3月17日 法律16号 (即日施行)
    (1959 1959 4 10 "皇太子明仁親王の結婚の儀")
    ;1966(昭和41)年6月25日 法律86号 (即日施行)
    (1967 nil 2 11 "建国記念の日")
    (1966 2002 9 15 "敬老の日")
    (1966 1999 10 10 "体育の日")
    ;1989(平成元)年2月17日 法律4号 (即日施行)
    (1989 1989 2 24 "昭和天皇の大喪の礼")
    ;1989(平成元)年2月17日 法律5号 (即日施行)
    (1989 nil 4 29 "みどりの日")
    (1989 nil 12 23 "天皇誕生日")
    ;1990(平成2)年6月1日 法律24号 (即日施行)
    (1990 1990 11 12 "即位礼正殿の儀")
    ;1993(平成5)年4月30日 法律32号 (即日施行)
    (1993 1993 6 9 "皇太子徳仁親王の結婚の儀")
    ;1995(平成7)年3月8日 法律22号 (1996(平成8)年1月1日施行)
    (1996 2002 7 20 "海の日")
    ;1998(平成10)年10月21日 法律141号 (2000(平成12)年1月1日施行)
    (2000 nil 1 (1 . 1) "成人の日")
    (2000 nil 10 (1 . 1) "体育の日")
    ;2001(平成13)年6月22日 法律59号 (2003(平成15)年1月1日施行)
    (2003 nil 7 (2 . 1) "海の日")
    (2003 nil 9 (2 . 1) "敬老の日")
    ))

(defun calendar-calc-equinox (year f)
  (let ((x (cdr (assoc year *calendar-equinox-parameter-list* :test #'<=))))
    (and x (truncate (- (+ (funcall f x) (* 0.242194 (- year 1980)))
			(truncate (- year (car x)) 4))))))

(defun calendar-vernal-equinox (year)
  (calendar-calc-equinox year #'cadr))

(defun calendar-autumnal-equinox (year)
  (calendar-calc-equinox year #'caddr))

(defun calendar-gregorian-p (year month day)
  (or (> year *calendar-gregorian-reform-year*)
      (and (= year *calendar-gregorian-reform-year*)
	   (or (> month *calendar-gregorian-reform-month*)
	       (and (= month *calendar-gregorian-reform-month*)
		    (>= day *calendar-gregorian-reform-day*))))))

(defun calendar-gregorian-leap-year-p (year)
  (or (zerop (rem year 400))
      (and (zerop (rem year 4))
	   (not (zerop (rem year 100))))))

(defun calendar-julian-leap-year-p (year)
  (zerop (rem year 4)))

(defun calendar-gregorian-last-day-of-month (year month)
  (if (and (= month 2) (calendar-gregorian-leap-year-p year))
      29
    (svref *calendar-last-day-of-month* month)))

(defun calendar-julian-last-day-of-month (year month)
  (if (and (= month 2) (calendar-julian-leap-year-p year))
      29
    (svref *calendar-last-day-of-month* month)))

(defun calendar-jd-from-ut (year month day &optional (gregorian-p
						      (calendar-gregorian-p
						       year month day)))
  (when (<= month 2)
    (decf year)
    (incf month 12))
  (+ (truncate (* 365.25 (+ year 4716)))
     (truncate (* 30.6001 (+ month 1)))
     day (if gregorian-p
	     (let ((a (truncate year 100)))
	       (- (truncate a 4) a -2))
	   0)
     -1524))

(defun calendar-ut-day (year month day)
  (rem (+ 1 (calendar-jd-from-ut year month day)) 7))

(defun calendar-japanese-holiday (year month v)
  (let ((sun (- 1 (calendar-ut-day year month 1)))
	;; 1985(昭和60)年12月27日 法律103号 (即日施行) - 国民の休日
	(nh (and (> year 1985) "国民の休日"))
	;; 1973(昭和48)年4月12日 法律10号 (即日施行) - 振替休日
	(ex (or (> year 1973) (and (= year 1973) (>= month 4)))))
    (dotimes (i (length v))
      (setf (svref v i) nil))
    (when (<= year *calendar-gregorian-reform-year*)
      (return-from calendar-japanese-holiday))
    (dolist (x *calendar-japanese-holiday-list*)
      (when (and (>= year (pop x))
		 (let ((e (pop x)))
		   (or (null e) (<= year e)))
		 (= month (pop x)))
	(let ((day (let ((d (pop x)))
		     (cond ((numberp d) d)
			   ((consp d)
			    (let ((n (+ (cdr d) sun)))
			      (+ (if (plusp n) n (+ n 7))
				 (* 7 (car d)))))
			   (t
			    (funcall d year))))))
	  (when day
	    (setf (svref v day) (car x))))))
    (when nh
      (do ((d 3 (+ d 1)))
	  ((>= d (length v)))
	(when (and (svref v d)
		   (not (svref v (- d 1)))
		   (svref v (- d 2)))
	  (setf (svref v (- d 1)) nh))))
    (do ((d (if (plusp sun) sun (+ sun 7)) (+ d 7)))
	((>= d (- (length v) 1)))
      (cond ((or (null (svref v d))
		 (eq (svref v d) nh))
	     (setf (svref v d) t))
	    ((and ex
		  (not (eq (svref v d) nh))
		  (or (eq (svref v (+ d 1)) nh)
		      (null (svref v (+ d 1)))))
	     (setf (svref v (+ d 1)) "振替休日"))))))

(defun calendar-forward-line (&optional (n 1))
  (dotimes (i n)
    (or (forward-line 1)
	(progn
	  (goto-eol)
	  (insert #\LFD)))))

(defun calendar-goto-column (column)
  (let ((indent-tabs-mode nil))
    (declare (special indent-tabs-mode))
    (goto-eol)
    (indent-to column)))

(defun calendar-title-string (year month)
  (if (plusp year)
      (format nil " ~D年~D月" year month)
    (format nil " BC~D年~D月" (- 1 year) month)))

(defun calendar-print-month (year month &optional today (column 0) (v (make-vector 33)))
  (let* ((dow (calendar-ut-day year month 1))
	 (generator (cond ((calendar-gregorian-p year month 1)
			   (let ((last (calendar-gregorian-last-day-of-month year month))
				 (day 0))
			     #'(lambda ()
				 (if (>= day last)
				     nil
				   (incf day)))))
			  ((if (= month 12)
			       (calendar-gregorian-p (+ year 1) 1 1)
			     (calendar-gregorian-p year (+ month 1) 1))
			   (let ((jd (calendar-jd-from-ut year month 1))
				 (reform-jd (calendar-jd-from-ut
					     *calendar-gregorian-reform-year*
					     *calendar-gregorian-reform-month*
					     *calendar-gregorian-reform-day*))
				 (last (calendar-gregorian-last-day-of-month year month))
				 (day 0))
			     #'(lambda ()
				 (cond ((< jd reform-jd)
					(incf jd)
					(incf day))
				       ((= jd reform-jd)
					(incf jd)
					(and (< day *calendar-gregorian-reform-day*)
					     (setq day *calendar-gregorian-reform-day*)))
				       ((= day last)
					nil)
				       (t
					(incf day))))))
			  (t
			   (let ((last (calendar-julian-last-day-of-month year month))
				 (day 0))
			     #'(lambda ()
				 (if (= day last)
				     nil
				   (incf day))))))))
    (calendar-japanese-holiday year month v)
    (calendar-goto-column column)
    (insert (calendar-title-string year month))
    (calendar-forward-line 1)
    (calendar-goto-column column)
    (dotimes (i 7)
      (let ((o (+ (point) 1)))
	(insert #\SPC (svref "日月火水木金土" i))
	(case i
	  (0 (set-text-attribute o (point) 'calendar :foreground 1))
	  (6 (set-text-attribute o (point) 'calendar :foreground 4)))))
    (calendar-forward-line 1)
    (calendar-goto-column (+ column (* dow 3)))
    (let (d)
      (while (setq d (funcall generator))
	(when (= dow 7)
	  (setq dow 0)
	  (calendar-forward-line 1)
	  (calendar-goto-column column))
	(let ((o (+ (point) 1)))
	  (insert (format nil " ~2D" d))
	  (cond ((or (svref v d)
		     (zerop dow))
		 (set-text-attribute o (point) (cons 'calendar (svref v d))
				     :foreground 1 :underline (eql d today)))
		((= dow 6)
		 (set-text-attribute o (point) 'calendar
				     :foreground 4 :underline (eql d today)))
		((eql d today)
		 (set-text-attribute o (point) 'calendar :underline t)))
	  (incf dow))))))

(defun calendar-print (year month nmonths y m d)
  (with-output-to-temp-buffer ("*Calendar*")
    (let ((v (make-vector 33))
	  (column 0)
	  (start (point)))
      (dotimes (i nmonths)
	(goto-char start)
	(calendar-print-month year month
			      (and (= year y) (= month m) d)
			      column v)
	(cond ((= column 48)
	       (goto-char start)
	       (calendar-forward-line 9)
	       (goto-bol)
	       (setq start (point))
	       (setq column 0))
	      (t
	       (incf column 24)))
	(cond ((= month 12)
	       (setq month 1)
	       (incf year))
	      (t
	       (incf month))))))
  (goto-char (point-min))
  (setq buffer-read-only t))

(defun calendar-popup ()
  (interactive)
  (setq calendar-range-begin nil)
  (multiple-value-bind (p1 p2 tag)
      (find-text-attribute-point (point))
    (when (and (consp tag)
	       (eq (car tag) 'calendar)
	       (stringp (cdr tag)))
      (setq calendar-range-begin p1)
      (setq calendar-range-end p2)
      (popup-string (cdr tag) p2))))

(defun calendar-mouse-popup ()
  (interactive)
  (save-excursion
    (goto-last-mouse-point)
    (cond ((and calendar-range-begin
		(>= (point) calendar-range-begin)
		(< (point) calendar-range-end))
	   (continue-popup))
	  (t
	   (calendar-popup)))))

(defun calendar-next-page-or-year (&optional (arg 1))
  (interactive)
  (unless (next-page arg)
    (incf calendar-current-year arg)
    (multiple-value-bind (s im h d m y)
	(decode-universal-time (get-universal-time))
      (calendar-print calendar-current-year 1 12 y m d)
      (when (minusp arg)
	(goto-char (point-max)))))
  t)

(defun calendar-previous-page-or-year (&optional (arg 1))
  (interactive)
  (calendar-next-page-or-year (- arg)))

(defun calendar (&optional year)
  (interactive "p")
  (let (month nmonths)
    (multiple-value-bind (s im h d m y)
	(decode-universal-time (get-universal-time))
      (cond (year
	     (setq month 1 nmonths 12))
	    (t
	     (if (<= m 6)
		 (setq month 7 year (- y 1))
	       (setq month 1 year y))
	     (setq nmonths 18)))
      (calendar-print year month nmonths y m d)
      (calendar-mode year)
      (scan-buffer (calendar-title-string y m))
      t)))

(defvar *calendar-mode-hook* nil)
(defvar *calendar-mode-map* nil)

(unless *calendar-mode-map*
  (setq *calendar-mode-map* (make-sparse-keymap))
  (define-key *calendar-mode-map* #\? 'calendar-popup)
  (define-key *calendar-mode-map* #\MouseMove 'calendar-mouse-popup)
  (define-key *calendar-mode-map* #\C-v 'calendar-next-page-or-year)
  (define-key *calendar-mode-map* #\M-v 'calendar-previous-page-or-year)
  (define-key *calendar-mode-map* #\C-z 'calendar-previous-page-or-year)
  (define-key *calendar-mode-map* #\q 'kill-selected-buffer)
  (define-key *calendar-mode-map* #\PageUp 'calendar-previous-page-or-year)
  (define-key *calendar-mode-map* #\PageDown 'calendar-next-page-or-year))

(defun calendar-mode (year)
  (kill-all-local-variables)
  (setq mode-name "Calendar")
  (setq buffer-mode 'calendar-mode)
  (use-keymap *calendar-mode-map*)
  (make-local-variable 'calendar-range-begin)
  (setq calendar-range-begin nil)
  (make-local-variable 'calendar-range-end)
  (setq calendar-range-end nil)
  (make-local-variable 'calendar-current-year)
  (setq calendar-current-year year)
  (run-hooks '*calendar-mode-hook*))
