Mercurial > emacs
changeset 92991:24a6717aed7f
(calendar-mark-1): Autoload it.
(mark-islamic-calendar-date-pattern): Add optional argument `color'.
Use calendar-mark-1.
(calendar-islamic-prompt-for-date): New function.
(calendar-goto-islamic-date): Use calendar-islamic-prompt-for-date.
| author | Glenn Morris <rgm@gnu.org> |
|---|---|
| date | Sun, 16 Mar 2008 01:24:21 +0000 |
| parents | 2d634b2258fb |
| children | 49c4ea77b83a |
| files | lisp/calendar/cal-islam.el |
| diffstat | 1 files changed, 43 insertions(+), 89 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/calendar/cal-islam.el Sun Mar 16 01:23:55 2008 +0000 +++ b/lisp/calendar/cal-islam.el Sun Mar 16 01:24:21 2008 +0000 @@ -73,18 +73,17 @@ (day (extract-calendar-day date)) (year (extract-calendar-year date)) (y (% year 30)) - (leap-years-in-cycle - (cond ((< y 3) 0) - ((< y 6) 1) - ((< y 8) 2) - ((< y 11) 3) - ((< y 14) 4) - ((< y 17) 5) - ((< y 19) 6) - ((< y 22) 7) - ((< y 25) 8) - ((< y 27) 9) - (t 10)))) + (leap-years-in-cycle (cond ((< y 3) 0) + ((< y 6) 1) + ((< y 8) 2) + ((< y 11) 3) + ((< y 14) 4) + ((< y 17) 5) + ((< y 19) 6) + ((< y 22) 7) + ((< y 25) 8) + ((< y 27) 9) + (t 10)))) (+ (islamic-calendar-day-number date) ; days so far this year (* (1- year) 354) ; days in all non-leap years (* 11 (/ year 30)) ; leap days in complete cycles @@ -142,31 +141,34 @@ (message "Date is pre-Islamic") (message "Islamic date (until sunset): %s" i)))) +(defun calendar-islamic-prompt-for-date () + "Ask for an Islamic date." + (let* ((today (calendar-current-date)) + (year (calendar-read + "Islamic calendar year (>0): " + (lambda (x) (> x 0)) + (int-to-string + (extract-calendar-year + (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian today)))))) + (month-array calendar-islamic-month-name-array) + (completion-ignore-case t) + (month (cdr (assoc-string + (completing-read + "Islamic calendar month name: " + (mapcar 'list (append month-array nil)) + nil t) + (calendar-make-alist month-array 1) t))) + (last (islamic-calendar-last-day-of-month month year)) + (day (calendar-read + (format "Islamic calendar day (1-%d): " last) + (lambda (x) (and (< 0 x) (<= x last)))))) + (list (list month day year)))) + ;;;###cal-autoload (defun calendar-goto-islamic-date (date &optional noecho) "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is non-nil." - (interactive - (let* ((today (calendar-current-date)) - (year (calendar-read - "Islamic calendar year (>0): " - (lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian today)))))) - (month-array calendar-islamic-month-name-array) - (completion-ignore-case t) - (month (cdr (assoc-string - (completing-read - "Islamic calendar month name: " - (mapcar 'list (append month-array nil)) - nil t) - (calendar-make-alist month-array 1) t))) - (last (islamic-calendar-last-day-of-month month year)) - (day (calendar-read - (format "Islamic calendar day (1-%d): " last) - (lambda (x) (and (< 0 x) (<= x last)))))) - (list (list month day year)))) + (interactive (calendar-islamic-prompt-for-date)) (calendar-goto-date (calendar-gregorian-from-absolute (calendar-absolute-from-islamic date))) (or noecho (calendar-print-islamic-date))) @@ -212,63 +214,15 @@ islamic-diary-entry-symbol 'calendar-islamic-from-absolute)) +(autoload 'calendar-mark-1 "diary-lib") + ;;;###diary-autoload -(defun mark-islamic-calendar-date-pattern (month day year) +(defun mark-islamic-calendar-date-pattern (month day year &optional color) "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (not (zerop month)) (not (zerop day))) - (if (not (zerop year)) - ;; Fully specified Islamic date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (unless (< m 1) ; Islamic calendar doesn't apply - (increment-calendar-month m y (- 10 month)) - (if (> m 7) ; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day y))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((i-date (calendar-islamic-from-absolute date)) - (i-month (extract-calendar-month i-date)) - (i-day (extract-calendar-day i-date)) - (i-year (extract-calendar-year i-date))) - (and (or (zerop month) - (= month i-month)) - (or (zerop day) - (= day i-day)) - (or (zerop year) - (= year i-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) +A value of 0 in any position is a wildcard. Optional argument COLOR is +passed to `mark-visible-calendar-date' as MARK." + (calendar-mark-1 month day year 'calendar-islamic-from-absolute + 'calendar-absolute-from-islamic color)) (autoload 'diary-mark-entries-1 "diary-lib")