-Each entry in diary-file (or included files) visible in the calendar
-window is marked. Bahá'í date entries are prefaced by a
-bahai-diary-entry-symbol \(normally a B`I'). The same
-diary-date-forms govern the style of the Bahá'í calendar entries,
-except that the Bahá'í month names must be spelled in full. The
-Bahá'í months are numbered from 1 to 12 with Bahá being 1 and 12 being
-`Alá. Bahá'í date diary entries that begin with a
-diary-nonmarking-symbol will not be marked in the calendar. This
-function is provided for use as part of the
-nongregorian-diary-marking-hook."
- (let ((d diary-date-forms))
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)));; ignore 'backup directive
- (dayname (diary-name-pattern calendar-day-name-array))
- (monthname
- (concat
- (diary-name-pattern calendar-bahai-month-name-array t)
- "\\|\\*"))
- (month "[0-9]+\\|\\*")
- (day "[0-9]+\\|\\*")
- (year "[0-9]+\\|\\*")
- (l (length date-form))
- (d-name-pos (- l (length (memq 'dayname date-form))))
- (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
- (m-name-pos (- l (length (memq 'monthname date-form))))
- (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
- (d-pos (- l (length (memq 'day date-form))))
- (d-pos (if (/= l d-pos) (+ 2 d-pos)))
- (m-pos (- l (length (memq 'month date-form))))
- (m-pos (if (/= l m-pos) (+ 2 m-pos)))
- (y-pos (- l (length (memq 'year date-form))))
- (y-pos (if (/= l y-pos) (+ 2 y-pos)))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)"
- (regexp-quote bahai-diary-entry-symbol)
- "\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (let* ((dd-name
- (if d-name-pos
- (buffer-substring
- (match-beginning d-name-pos)
- (match-end d-name-pos))))
- (mm-name
- (if m-name-pos
- (buffer-substring
- (match-beginning m-name-pos)
- (match-end m-name-pos))))
- (mm (string-to-number
- (if m-pos
- (buffer-substring
- (match-beginning m-pos)
- (match-end m-pos))
- "")))
- (dd (string-to-number
- (if d-pos
- (buffer-substring
- (match-beginning d-pos)
- (match-end d-pos))
- "")))
- (y-str (if y-pos
- (buffer-substring
- (match-beginning y-pos)
- (match-end y-pos))))
- (yy (if (not y-str)
- 0
- (if (and (= (length y-str) 2)
- abbreviated-calendar-year)
- (let* ((current-y
- (extract-calendar-year
- (calendar-bahai-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date)))))
- (y (+ (string-to-number y-str)
- (* 100 (/ current-y 100)))))
- (if (> (- y current-y) 50)
- (- y 100)
- (if (> (- current-y y) 50)
- (+ y 100)
- y)))
- (string-to-number y-str)))))
- (if dd-name
- (mark-calendar-days-named
- (cdr (assoc-string (substring dd-name 0 3)
- (calendar-make-alist
- calendar-day-name-array
- 0
- '(lambda (x) (substring x 0 3)))
- t)))
- (if mm-name
- (if (string-equal mm-name "*")
- (setq mm 0)
- (setq mm
- (cdr (assoc-string
- mm-name
- (calendar-make-alist
- calendar-bahai-month-name-array)
- t)))))
- (calendar-bahai-mark-date-pattern mm dd yy)))))
- (setq d (cdr d)))))
-
-(defun calendar-bahai-mark-date-pattern (month day year)
- "Mark dates in calendar window that conform to Bahá'í date MONTH/DAY/YEAR.
-A value of 0 in any position is a wildcard."
- (save-excursion
- (set-buffer calendar-buffer)
- (if (and (/= 0 month) (/= 0 day))
- (if (/= 0 year)
- ;; Fully specified Bahá'í date.
- (let ((date (calendar-gregorian-from-absolute
- (calendar-absolute-from-bahai
- (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* ((bahai-date (calendar-bahai-from-absolute
- (calendar-absolute-from-gregorian
- (list displayed-month 15 displayed-year))))
- (m (extract-calendar-month bahai-date))
- (y (extract-calendar-year bahai-date))
- (date))
- (if (< m 1)
- nil;; Bahá'í calendar doesn't apply.
- (increment-calendar-month m y (- 10 month))
- (if (> m 7);; Bahá'í date might be visible
- (let ((date (calendar-gregorian-from-absolute
- (calendar-absolute-from-bahai
- (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* ((b-date (calendar-bahai-from-absolute date))
- (i-month (extract-calendar-month b-date))
- (i-day (extract-calendar-day b-date))
- (i-year (extract-calendar-year b-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)))))))))