bug#17393: 24.4.50; [PATCH] diary Chinese support

[Leo Liu]

The patch adds support for Chinese dates in diary, in which the cycle
and year are concatenated as cycleyear i.e. cycle 78 and year 31 is
represented as 7831. The following commands are available in the
calendar window:

 KEY      COMMAND
 ======   ======================================
`i C a'   diary-chinese-insert-anniversary-entry
`i C d'   diary-chinese-insert-entry
`i C m'   diary-chinese-insert-monthly-entry
`i C y'   diary-chinese-insert-yearly-entry
 ======   ======================================

=== modified file 'lisp/calendar/cal-china.el'
--- lisp/calendar/cal-china.el  2014-01-01 07:43:34 +0000
+++ lisp/calendar/cal-china.el  2014-05-03 04:15:59 +0000
@@ -682,6 +682,124 @@
   "Chinese calendar equivalent of date diary entry."
   (format "Chinese date: %s" (calendar-chinese-date-string date)))
 
+;;;; diary support
+
+(declare-function calendar-mark-1         "diary-lib")
+(declare-function diary-mark-entries-1    "diary-lib")
+(declare-function diary-list-entries-1    "diary-lib")
+(declare-function diary-insert-entry-1    "diary-lib")
+(declare-function diary-date-display-form "diary-lib")
+(declare-function diary-anniversary       "diary-lib")
+(declare-function diary-make-date         "diary-lib")
+(declare-function diary-ordinal-suffix    "diary-lib")
+(defvar diary-sexp-entry-symbol)
+(defvar entry)                    ;used by `diary-chinese-anniversary'
+
+(defvar calendar-chinese-month-name-array
+  ["正月" "二月" "三月" "四月" "五月" "六月"
+   "七月" "八月" "九月" "十月" "冬月" "臘月"])
+
+;;; NOTE: In the diary the cycle and year of a Chinese date is
+;;; combined using this formula: (+ (* cycle 100) year).
+;;;
+;;; These two functions convert to and back from this representation.
+(defun calendar-chinese-from-absolute-for-diary (date)
+  (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date)))
+    (list m d (+ (* c 100) y))))
+
+(defun calendar-chinese-to-absolute-for-diary (date)
+  (pcase-let ((`(,m ,d ,y) date))
+    (calendar-chinese-to-absolute
+     (list (floor y 100) (mod y 100) m d))))
+
+(defun calendar-chinese-mark-date-pattern (month day year &optional color)
+  (calendar-mark-1 month day year
+                   #'calendar-chinese-from-absolute-for-diary
+                   #'calendar-chinese-to-absolute-for-diary
+                   color))
+
+;;;###cal-autoload
+(defun diary-chinese-mark-entries ()
+  "Mark days in the calendar window that have Chinese date diary entries.
+Marks each entry in `diary-file' (or included files) visible in the calendar
+window.  See `diary-chinese-list-entries' for more information.
+
+This function is provided for use with `diary-nongregorian-marking-hook'."
+  (diary-mark-entries-1 #'calendar-chinese-mark-date-pattern
+                        calendar-chinese-month-name-array
+                        diary-chinese-entry-symbol
+                        #'calendar-chinese-from-absolute-for-diary))
+
+;;;###cal-autoload
+(defun diary-chinese-list-entries ()
+  "Add any Chinese date entries from the diary file to `diary-entries-list'.
+Chinese date diary entries must be prefaced by `diary-chinese-entry-symbol'
+\(normally an `C').  The same `diary-date-forms' govern the style
+of the Chinese calendar entries.  If an Chinese date diary entry begins with
+`diary-nonmarking-symbol', the entry will appear in the diary listing,
+but will not be marked in the calendar.
+
+This function is provided for use with `diary-nongregorian-listing-hook'."
+  (diary-list-entries-1 calendar-chinese-month-name-array
+                        diary-chinese-entry-symbol
+                        #'calendar-chinese-from-absolute-for-diary))
+
+;;;###cal-autoload
+(defun diary-chinese-anniversary (month day &optional year mark)
+  (pcase-let* ((ddate (diary-make-date month day year))
+               (`(,dc ,dy ,dm ,dd)      ;diary chinese date
+                (if year
+                    (calendar-chinese-from-absolute
+                     (calendar-chinese-to-absolute-for-diary ddate))
+                  (list nil nil (calendar-extract-month ddate)
+                        (calendar-extract-day ddate))))
+               (`(,cc ,cy ,cm ,cd)      ;current chinese date
+                (calendar-chinese-from-absolute
+                 (calendar-absolute-from-gregorian date)))
+               (diff (if (and dc dy)
+                         (+ (* 60 (- cc dc)) (- cy dy))
+                       100)))
+    (and (> diff 0) (= dm cm) (= dd cd)
+         (cons mark (format entry diff (diary-ordinal-suffix diff))))))
+
+;;;###cal-autoload
+(defun diary-chinese-insert-anniversary-entry (&optional arg)
+  "Insert an anniversary diary entry for the Chinese date at point.
+Prefix argument ARG makes the entry nonmarking."
+  (interactive "P")
+  (let ((calendar-date-display-form (diary-date-display-form)))
+    (diary-make-entry
+     (format "%s(diary-chinese-anniversary %s)"
+             diary-sexp-entry-symbol
+             (calendar-date-string
+              (calendar-chinese-from-absolute-for-diary
+               (calendar-absolute-from-gregorian (calendar-cursor-to-date 
t)))))
+     arg)))
+
+;;;###cal-autoload
+(defun diary-chinese-insert-entry (&optional arg)
+  "Insert a diary entry for the Chinese date at point."
+  (interactive "P")
+  (diary-insert-entry-1 nil arg calendar-chinese-month-name-array
+                        diary-chinese-entry-symbol
+                        #'calendar-chinese-from-absolute-for-diary))
+
+;;;###cal-autoload
+(defun diary-chinese-insert-monthly-entry (&optional arg)
+  "Insert a monthly diary entry for the Chinese date at point."
+  (interactive "P")
+  (diary-insert-entry-1 'monthly arg calendar-chinese-month-name-array
+                        diary-chinese-entry-symbol
+                        #'calendar-chinese-from-absolute-for-diary))
+
+;;;###cal-autoload
+(defun diary-chinese-insert-yearly-entry (&optional arg)
+  "Insert a yearly diary entry for the Chinese date at point."
+  (interactive "P")
+  (diary-insert-entry-1 'yearly arg calendar-chinese-month-name-array
+                        diary-chinese-entry-symbol
+                        #'calendar-chinese-from-absolute-for-diary))
+
 (provide 'cal-china)
 
 ;;; cal-china.el ends here

=== modified file 'lisp/calendar/cal-menu.el'
--- lisp/calendar/cal-menu.el   2014-01-01 07:43:34 +0000
+++ lisp/calendar/cal-menu.el   2014-05-03 04:15:59 +0000
@@ -56,6 +56,11 @@
      ["One time" diary-bahai-insert-entry]
      ["Monthly" diary-bahai-insert-monthly-entry]
      ["Yearly" diary-bahai-insert-yearly-entry])
+    ("Insert Chinese"
+     ["One time" diary-chinese-insert-entry]
+     ["Monthly" diary-chinese-insert-monthly-entry]
+     ["Yearly" diary-chinese-insert-yearly-entry]
+     ["Anniversary" diary-chinese-insert-anniversary-entry])
     ("Insert Islamic"
      ["One time" diary-islamic-insert-entry]
      ["Monthly" diary-islamic-insert-monthly-entry]

=== modified file 'lisp/calendar/calendar.el'
--- lisp/calendar/calendar.el   2014-03-17 16:04:32 +0000
+++ lisp/calendar/calendar.el   2014-05-03 04:15:59 +0000
@@ -689,6 +689,11 @@
   :type 'string
   :group 'diary)
 
+(defcustom diary-chinese-entry-symbol "C"
+  "Symbol indicating a diary entry according to the Chinese calendar."
+  :type 'string
+  :group 'diary)
+
 (define-obsolete-variable-alias 'hebrew-diary-entry-symbol
   'diary-hebrew-entry-symbol "23.1")
 
@@ -1709,6 +1714,10 @@
     (define-key map "iBd" 'diary-bahai-insert-entry)
     (define-key map "iBm" 'diary-bahai-insert-monthly-entry)
     (define-key map "iBy" 'diary-bahai-insert-yearly-entry)
+    (define-key map "iCd" 'diary-chinese-insert-entry)
+    (define-key map "iCm" 'diary-chinese-insert-monthly-entry)
+    (define-key map "iCy" 'diary-chinese-insert-yearly-entry)
+    (define-key map "iCa" 'diary-chinese-insert-anniversary-entry)
     (define-key map "?"   'calendar-goto-info-node)
     (define-key map "Hm" 'cal-html-cursor-month)
     (define-key map "Hy" 'cal-html-cursor-year)

=== modified file 'lisp/calendar/diary-lib.el'
--- lisp/calendar/diary-lib.el  2014-01-01 07:43:34 +0000
+++ lisp/calendar/diary-lib.el  2014-05-03 04:15:59 +0000
@@ -2396,6 +2396,11 @@
                                cal-bahai
                                calendar-bahai-month-name-array
                                diary-bahai-entry-symbol)
+   (diary-font-lock-keywords-1 diary-chinese-mark-entries
+                               diary-chinese-list-entries
+                               cal-china
+                               calendar-chinese-month-name-array
+                               diary-chinese-entry-symbol)
    (list
     (cons
      (format "^%s.*$" (regexp-quote diary-include-string))
@@ -2412,7 +2417,8 @@
              (regexp-opt (mapcar 'regexp-quote
                                  (list diary-hebrew-entry-symbol
                                        diary-islamic-entry-symbol
-                                       diary-bahai-entry-symbol))
+                                       diary-bahai-entry-symbol
+                                       diary-chinese-entry-symbol))
                          t))
      '(1 font-lock-constant-face))
     '(diary-font-lock-sexps . font-lock-keyword-face)