diff options
Diffstat (limited to 'lisp/calendar/cal-china.el')
-rw-r--r-- | lisp/calendar/cal-china.el | 118 |
1 files changed, 118 insertions, 0 deletions
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index 538d2320b30..e266613680a 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -682,6 +682,124 @@ Echo Chinese date unless NOECHO is non-nil." "Chinese calendar equivalent of date diary entry." (format "Chinese date: %s" (calendar-chinese-date-string date))) +;;;; diary support + +(autoload 'calendar-mark-1 "diary-lib") +(autoload 'diary-mark-entries-1 "diary-lib") +(autoload 'diary-list-entries-1 "diary-lib") +(autoload 'diary-insert-entry-1 "diary-lib") +(autoload 'diary-date-display-form "diary-lib") +(autoload 'diary-make-date "diary-lib") +(autoload '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 prefixed by `diary-chinese-entry-symbol' +\(normally a `C'). The same `diary-date-forms' govern the style +of the Chinese calendar entries. If a 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) + "Like `diary-anniversary' (which see) but accepts Chinese date." + (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 |