[bpt/emacs.git] / lisp / calendar / cal-bahai.el

;;; cal-bahai.el --- calendar functions for the Baha'i calendar.

;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
;;   Free Software Foundation, Inc.

;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Baha'i calendar, Baha'i, Bahai, calendar, diary

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This collection of functions implements the features of calendar.el
;; and diary.el that deal with the Baha'i calendar.

;; The Baha'i (http://www.bahai.org) calendar system is based on a
;; solar cycle of 19 months with 19 days each.  The four remaining
;; "intercalary" days are called the Ayyam-i-Ha (days of Ha), and are
;; placed between the 18th and 19th months.  They are meant as a time
;; of festivals preceding the 19th month, which is the month of
;; fasting.  In Gregorian leap years, there are 5 of these days (Ha
;; has the numerical value of 5 in the arabic abjad, or
;; letter-to-number, reckoning).

;; Each month is named after an attribute of God, as are the 19 days
;; -- which have the same names as the months.  There is also a name
;; for each year in every 19 year cycle.  These cycles are called
;; Vahids.  A cycle of 19 Vahids (361 years) is called a Kullu-Shay,
;; which means "all things".

;; The calendar was named the "Badi calendar" by its author, the Bab.
;; It uses a week of seven days, corresponding to the Gregorian week,
;; each of which has its own name, again patterned after the
;; attributes of God.

;; Note: The days of Ayyam-i-Ha are encoded as zero and negative
;; offsets from the first day of the final month.  So, (19 -3 157) is
;; the first day of Ayyam-i-Ha, in the year 157 BE.

;;; Code:

(defvar date)
(defvar displayed-month)
(defvar displayed-year)
(defvar number)
(defvar original-date)

(require 'cal-julian)

(defvar bahai-calendar-month-name-array
  ["Baha" "Jalal" "Jamal" "`Azamat" "Nur" "Rahmat" "Kalimat" "Kamal"
   "Asma" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masa'il"
   "Sharaf" "Sultan" "Mulk" "`Ala"])

(defvar calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844))
  "Absolute date of start of Baha'i calendar = March 19, 622 A.D. (Julian).")

(defun bahai-calendar-leap-year-p (year)
  "True if YEAR is a leap year on the Baha'i calendar."
  (calendar-leap-year-p (+ year 1844)))

(defvar bahai-calendar-leap-base
  (+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400)))

(defun calendar-absolute-from-bahai (date)
  "Compute absolute date from Baha'i date DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
  (let* ((month (extract-calendar-month date))
	 (day (extract-calendar-day date))
	 (year (extract-calendar-year date))
	 (prior-years (+ (1- year) 1844))
	 (leap-days (- (+ (/ prior-years 4) ; Leap days in prior years.
			  (- (/ prior-years 100))
			  (/ prior-years 400))
		       bahai-calendar-leap-base)))
    (+ (1- calendar-bahai-epoch)	; Days before epoch
       (* 365 (1- year))		; Days in prior years.
       leap-days
       (calendar-sum m 1 (< m month) 19)
       (if (= month 19) 4 0)
       day)))				; Days so far this month.

(defun calendar-bahai-from-absolute (date)
  "Baha'i year corresponding to the absolute DATE."
  (if (< date calendar-bahai-epoch)
      (list 0 0 0) ;; pre-Baha'i date
    (let* ((greg (calendar-gregorian-from-absolute date))
	   (year (+ (- (extract-calendar-year greg) 1844)
		    (if (or (> (extract-calendar-month greg) 3)
			    (and (= (extract-calendar-month greg) 3)
				 (>= (extract-calendar-day greg) 21)))
			1 0)))
           (month ;; Search forward from Baha.
            (1+ (calendar-sum m 1
			      (> date
				 (calendar-absolute-from-bahai
				  (list m 19 year)))
			      1)))
           (day	;; Calculate the day by subtraction.
            (- date
               (1- (calendar-absolute-from-bahai (list month 1 year))))))
      (list month day year))))

(defun calendar-bahai-date-string (&optional date)
  "String of Baha'i date of Gregorian DATE.
Defaults to today's date if DATE is not given."
  (let* ((bahai-date (calendar-bahai-from-absolute
                       (calendar-absolute-from-gregorian
                        (or date (calendar-current-date)))))
         (y (extract-calendar-year bahai-date))
         (m (extract-calendar-month bahai-date))
         (d (extract-calendar-day bahai-date)))
    (let ((monthname
	   (if (and (= m 19)
		    (<= d 0))
	       "Ayyam-i-Ha"
	     (aref bahai-calendar-month-name-array (1- m))))
	  (day (int-to-string
		(if (<= d 0)
		    (if (bahai-calendar-leap-year-p y)
			(+ d 5)
		      (+ d 4))
		  d)))
	  (dayname nil)
	  (month (int-to-string m))
	  (year (int-to-string y)))
      (mapconcat 'eval calendar-date-display-form ""))))

(defun calendar-print-bahai-date ()
  "Show the Baha'i calendar equivalent of the selected date."
  (interactive)
  (message "Baha'i date: %s"
           (calendar-bahai-date-string (calendar-cursor-to-date t))))

(defun calendar-goto-bahai-date (date &optional noecho)
  "Move cursor to Baha'i date DATE.
Echo Baha'i date unless NOECHO is t."
  (interactive (bahai-prompt-for-date))
  (calendar-goto-date (calendar-gregorian-from-absolute
                       (calendar-absolute-from-bahai date)))
  (or noecho (calendar-print-bahai-date)))

(defun bahai-prompt-for-date ()
  "Ask for a Baha'i date."
  (let* ((today (calendar-current-date))
         (year (calendar-read
                "Baha'i calendar year (not 0): "
                '(lambda (x) (/= x 0))
                (int-to-string
                 (extract-calendar-year
                  (calendar-bahai-from-absolute
                   (calendar-absolute-from-gregorian today))))))
         (completion-ignore-case t)
         (month (cdr (assoc
                       (completing-read
                        "Baha'i calendar month name: "
                        (mapcar 'list
                                (append bahai-calendar-month-name-array nil))
                        nil t)
                      (calendar-make-alist bahai-calendar-month-name-array
                                           1))))
         (day (calendar-read "Baha'i calendar day (1-19): "
			     '(lambda (x) (and (< 0 x) (<= x 19))))))
    (list (list month day year))))

(defun diary-bahai-date ()
  "Baha'i calendar equivalent of date diary entry."
  (format "Baha'i date: %s" (calendar-bahai-date-string date)))

(defun holiday-bahai (month day string)
  "Holiday on MONTH, DAY (Baha'i) called STRING.
If MONTH, DAY (Baha'i) is visible, the value returned is corresponding
Gregorian date in the form of the list (((month day year) STRING)).  Returns
nil if it is not visible in the current calendar window."
  (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 ;;   Baha'i calendar doesn't apply.
      (increment-calendar-month m y (- 10 month))
      (if (> m 7) ;;  Baha'i 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)
                (list (list date string))))))))

(defun list-bahai-diary-entries ()
  "Add any Baha'i date entries from the diary file to `diary-entries-list'.
Baha'i date diary entries must be prefaced by an
`bahai-diary-entry-symbol' (normally a `B').  The same diary date
forms govern the style of the Baha'i calendar entries, except that the
Baha'i month names must be given numerically.  The Baha'i months are
numbered from 1 to 19 with Baha being 1 and 19 being `Ala.  If a
Baha'i date diary entry begins with a `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 the
`nongregorian-diary-listing-hook'."
  (if (< 0 number)
      (let ((buffer-read-only nil)
            (diary-modified (buffer-modified-p))
            (gdate original-date)
            (mark (regexp-quote diary-nonmarking-symbol)))
        (dotimes (idummy number)
          (let* ((d diary-date-forms)
                 (bdate (calendar-bahai-from-absolute
                         (calendar-absolute-from-gregorian gdate)))
                 (month (extract-calendar-month bdate))
                 (day (extract-calendar-day bdate))
                 (year (extract-calendar-year bdate)))
            (while d
              (let*
                  ((date-form (if (equal (car (car d)) 'backup)
                                  (cdr (car d))
                                (car d)))
                   (backup (equal (car (car d)) 'backup))
                   (dayname
                    (concat
                     (calendar-day-name gdate) "\\|"
                     (substring (calendar-day-name gdate) 0 3) ".?"))
                   (calendar-month-name-array
                    bahai-calendar-month-name-array)
                   (monthname
                    (concat
                     "\\*\\|"
                     (calendar-month-name month)))
                   (month (concat "\\*\\|0*" (int-to-string month)))
                   (day (concat "\\*\\|0*" (int-to-string day)))
                   (year
                    (concat
                     "\\*\\|0*" (int-to-string year)
                     (if abbreviated-calendar-year
                         (concat "\\|" (int-to-string (% year 100)))
                       "")))
                   (regexp
                    (concat
                     "\\(\\`\\|\^M\\|\n\\)" mark "?"
                     (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)
                  (if backup (re-search-backward "\\<" nil t))
                  (if (and (or (char-equal (preceding-char) ?\^M)
                               (char-equal (preceding-char) ?\n))
                           (not (looking-at " \\|\^I")))
                      ;;  Diary entry that consists only of date.
                      (backward-char 1)
                    ;;  Found a nonempty diary entry--make it visible and
                    ;;  add it to the list.
                    (let ((entry-start (point))
                          (date-start))
                      (re-search-backward "\^M\\|\n\\|\\`")
                      (setq date-start (point))
                      (re-search-forward "\^M\\|\n" nil t 2)
                      (while (looking-at " \\|\^I")
                        (re-search-forward "\^M\\|\n" nil t))
                      (backward-char 1)
                      (subst-char-in-region date-start (point) ?\^M ?\n t)
                      (add-to-diary-list
                       gdate
                       (buffer-substring-no-properties entry-start (point))
                       (buffer-substring-no-properties
                        (1+ date-start) (1- entry-start)))))))
              (setq d (cdr d))))
          (setq gdate
                (calendar-gregorian-from-absolute
                 (1+ (calendar-absolute-from-gregorian gdate)))))
        (set-buffer-modified-p diary-modified))
    (goto-char (point-min))))

(defun mark-bahai-diary-entries ()
  "Mark days in the calendar window that have Baha'i date diary entries.
Each entry in diary-file (or included files) visible in the calendar
window is marked.  Baha'i date entries are prefaced by a
bahai-diary-entry-symbol \(normally a B`I').  The same
diary-date-forms govern the style of the Baha'i calendar entries,
except that the Baha'i month names must be spelled in full.  The
Baha'i months are numbered from 1 to 12 with Baha being 1 and 12 being
`Ala.  Baha'i 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 bahai-calendar-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
                                  bahai-calendar-month-name-array)
                                t)))))
              (mark-bahai-calendar-date-pattern mm dd yy)))))
      (setq d (cdr d)))))

(defun mark-bahai-calendar-date-pattern (month day year)
  "Mark dates in calendar window that conform to Baha'i 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 Baha'i 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;;   Baha'i calendar doesn't apply.
              (increment-calendar-month m y (- 10 month))
              (if (> m 7);;  Baha'i 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)))))))))

(defun insert-bahai-diary-entry (arg)
  "Insert a diary entry.
For the Baha'i date corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
  (interactive "P")
  (let* ((calendar-month-name-array bahai-calendar-month-name-array))
    (make-diary-entry
     (concat
      bahai-diary-entry-symbol
      (calendar-date-string
       (calendar-bahai-from-absolute
        (calendar-absolute-from-gregorian
         (calendar-cursor-to-date t)))
       nil t))
     arg)))

(defun insert-monthly-bahai-diary-entry (arg)
  "Insert a monthly diary entry.
For the day of the Baha'i month corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
  (interactive "P")
  (let* ((calendar-date-display-form
          (if european-calendar-style '(day " * ") '("* " day )))
         (calendar-month-name-array bahai-calendar-month-name-array))
    (make-diary-entry
     (concat
      bahai-diary-entry-symbol
      (calendar-date-string
       (calendar-bahai-from-absolute
        (calendar-absolute-from-gregorian
         (calendar-cursor-to-date t)))))
     arg)))

(defun insert-yearly-bahai-diary-entry (arg)
  "Insert an annual diary entry.
For the day of the Baha'i year corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
  (interactive "P")
  (let* ((calendar-date-display-form
          (if european-calendar-style
              '(day " " monthname)
            '(monthname " " day)))
         (calendar-month-name-array bahai-calendar-month-name-array))
    (make-diary-entry
     (concat
      bahai-diary-entry-symbol
      (calendar-date-string
       (calendar-bahai-from-absolute
        (calendar-absolute-from-gregorian
         (calendar-cursor-to-date t)))))
     arg)))

(provide 'cal-bahai)

;;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
;;; cal-bahai.el ends here
Commit	Line	Data
811a8484 JW	1	;;; cal-bahai.el --- calendar functions for the Baha'i calendar.
811a8484 JW	2
f0fa15c5	3	;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
a20b3848	4	;; Free Software Foundation, Inc.
811a8484 JW	5
	6	;; Author: John Wiegley <johnw@gnu.org>
	7	;; Keywords: calendar
	8	;; Human-Keywords: Baha'i calendar, Baha'i, Bahai, calendar, diary
	9
	10	;; This file is part of GNU Emacs.
	11
	12	;; GNU Emacs is free software; you can redistribute it and/or modify
	13	;; it under the terms of the GNU General Public License as published by
075969b4	14	;; the Free Software Foundation; either version 3, or (at your option)
811a8484 JW	15	;; any later version.
	16
	17	;; GNU Emacs is distributed in the hope that it will be useful,
	18	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;; GNU General Public License for more details.
	21
	22	;; You should have received a copy of the GNU General Public License
	23	;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56 LK	24	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
3a35cf56 LK	25	;; Boston, MA 02110-1301, USA.
811a8484 JW	26
	27	;;; Commentary:
	28
	29	;; This collection of functions implements the features of calendar.el
	30	;; and diary.el that deal with the Baha'i calendar.
	31
	32	;; The Baha'i (http://www.bahai.org) calendar system is based on a
	33	;; solar cycle of 19 months with 19 days each. The four remaining
	34	;; "intercalary" days are called the Ayyam-i-Ha (days of Ha), and are
	35	;; placed between the 18th and 19th months. They are meant as a time
	36	;; of festivals preceding the 19th month, which is the month of
	37	;; fasting. In Gregorian leap years, there are 5 of these days (Ha
	38	;; has the numerical value of 5 in the arabic abjad, or
	39	;; letter-to-number, reckoning).
	40
	41	;; Each month is named after an attribute of God, as are the 19 days
	42	;; -- which have the same names as the months. There is also a name
	43	;; for each year in every 19 year cycle. These cycles are called
	44	;; Vahids. A cycle of 19 Vahids (361 years) is called a Kullu-Shay,
	45	;; which means "all things".
	46
	47	;; The calendar was named the "Badi calendar" by its author, the Bab.
	48	;; It uses a week of seven days, corresponding to the Gregorian week,
	49	;; each of which has its own name, again patterned after the
	50	;; attributes of God.
	51
	52	;; Note: The days of Ayyam-i-Ha are encoded as zero and negative
	53	;; offsets from the first day of the final month. So, (19 -3 157) is
	54	;; the first day of Ayyam-i-Ha, in the year 157 BE.
	55
	56	;;; Code:
	57
916f8173 JB	58	(defvar date)
	59	(defvar displayed-month)
	60	(defvar displayed-year)
	61	(defvar number)
	62	(defvar original-date)
	63
811a8484 JW	64	(require 'cal-julian)
	65
	66	(defvar bahai-calendar-month-name-array
	67	["Baha" "Jalal" "Jamal" "`Azamat" "Nur" "Rahmat" "Kalimat" "Kamal"
	68	"Asma" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masa'il"
	69	"Sharaf" "Sultan" "Mulk" "`Ala"])
	70
	71	(defvar calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844))
	72	"Absolute date of start of Baha'i calendar = March 19, 622 A.D. (Julian).")
	73
	74	(defun bahai-calendar-leap-year-p (year)
	75	"True if YEAR is a leap year on the Baha'i calendar."
	76	(calendar-leap-year-p (+ year 1844)))
	77
	78	(defvar bahai-calendar-leap-base
	79	(+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400)))
	80
	81	(defun calendar-absolute-from-bahai (date)
	82	"Compute absolute date from Baha'i date DATE.
	83	The absolute date is the number of days elapsed since the (imaginary)
	84	Gregorian date Sunday, December 31, 1 BC."
	85	(let* ((month (extract-calendar-month date))
	86	(day (extract-calendar-day date))
	87	(year (extract-calendar-year date))
	88	(prior-years (+ (1- year) 1844))
	89	(leap-days (- (+ (/ prior-years 4) ; Leap days in prior years.
	90	(- (/ prior-years 100))
	91	(/ prior-years 400))
	92	bahai-calendar-leap-base)))
	93	(+ (1- calendar-bahai-epoch) ; Days before epoch
	94	(* 365 (1- year)) ; Days in prior years.
	95	leap-days
	96	(calendar-sum m 1 (< m month) 19)
	97	(if (= month 19) 4 0)
	98	day))) ; Days so far this month.
	99
	100	(defun calendar-bahai-from-absolute (date)
	101	"Baha'i year corresponding to the absolute DATE."
	102	(if (< date calendar-bahai-epoch)
	103	(list 0 0 0) ;; pre-Baha'i date
	104	(let* ((greg (calendar-gregorian-from-absolute date))
	105	(year (+ (- (extract-calendar-year greg) 1844)
	106	(if (or (> (extract-calendar-month greg) 3)
	107	(and (= (extract-calendar-month greg) 3)
	108	(>= (extract-calendar-day greg) 21)))
	109	1 0)))
	110	(month ;; Search forward from Baha.
	111	(1+ (calendar-sum m 1
	112	(> date
	113	(calendar-absolute-from-bahai
	114	(list m 19 year)))
	115	1)))
	116	(day ;; Calculate the day by subtraction.
	117	(- date
	118	(1- (calendar-absolute-from-bahai (list month 1 year))))))
	119	(list month day year))))
	120
	121	(defun calendar-bahai-date-string (&optional date)
	122	"String of Baha'i date of Gregorian DATE.
	123	Defaults to today's date if DATE is not given."
	124	(let* ((bahai-date (calendar-bahai-from-absolute
	125	(calendar-absolute-from-gregorian
	126	(or date (calendar-current-date)))))
	127	(y (extract-calendar-year bahai-date))
128	(m (extract-calendar-month bahai-date))
129	(d (extract-calendar-day bahai-date)))
130	(let ((monthname
131	(if (and (= m 19)
132	(<= d 0))
133	"Ayyam-i-Ha"
134	(aref bahai-calendar-month-name-array (1- m))))
135	(day (int-to-string
136	(if (<= d 0)
137	(if (bahai-calendar-leap-year-p y)
138	(+ d 5)
139	(+ d 4))
140	d)))
141	(dayname nil)
142	(month (int-to-string m))
143	(year (int-to-string y)))
144	(mapconcat 'eval calendar-date-display-form ""))))
145
146	(defun calendar-print-bahai-date ()
147	"Show the Baha'i calendar equivalent of the selected date."
148	(interactive)
149	(message "Baha'i date: %s"
150	(calendar-bahai-date-string (calendar-cursor-to-date t))))
151
152	(defun calendar-goto-bahai-date (date &optional noecho)
153	"Move cursor to Baha'i date DATE.
154	Echo Baha'i date unless NOECHO is t."
155	(interactive (bahai-prompt-for-date))
156	(calendar-goto-date (calendar-gregorian-from-absolute
157	(calendar-absolute-from-bahai date)))
158	(or noecho (calendar-print-bahai-date)))
159
160	(defun bahai-prompt-for-date ()
161	"Ask for a Baha'i date."
162	(let* ((today (calendar-current-date))
163	(year (calendar-read
164	"Baha'i calendar year (not 0): "
165	'(lambda (x) (/= x 0))
166	(int-to-string
167	(extract-calendar-year
168	(calendar-bahai-from-absolute
169	(calendar-absolute-from-gregorian today))))))
170	(completion-ignore-case t)
171	(month (cdr (assoc
172	(completing-read
173	"Baha'i calendar month name: "
174	(mapcar 'list
175	(append bahai-calendar-month-name-array nil))
176	nil t)
177	(calendar-make-alist bahai-calendar-month-name-array
178	1))))
179	(day (calendar-read "Baha'i calendar day (1-19): "
180	'(lambda (x) (and (< 0 x) (<= x 19))))))
181	(list (list month day year))))
182
183	(defun diary-bahai-date ()
184	"Baha'i calendar equivalent of date diary entry."
185	(format "Baha'i date: %s" (calendar-bahai-date-string date)))
186
187	(defun holiday-bahai (month day string)
188	"Holiday on MONTH, DAY (Baha'i) called STRING.
189	If MONTH, DAY (Baha'i) is visible, the value returned is corresponding
190	Gregorian date in the form of the list (((month day year) STRING)). Returns
191	nil if it is not visible in the current calendar window."
192	(let* ((bahai-date (calendar-bahai-from-absolute
193	(calendar-absolute-from-gregorian
194	(list displayed-month 15 displayed-year))))
195	(m (extract-calendar-month bahai-date))
196	(y (extract-calendar-year bahai-date))
197	(date))
198	(if (< m 1)
199	nil ;; Baha'i calendar doesn't apply.
200	(increment-calendar-month m y (- 10 month))
201	(if (> m 7) ;; Baha'i date might be visible
202	(let ((date (calendar-gregorian-from-absolute
203	(calendar-absolute-from-bahai (list month day y)))))
204	(if (calendar-date-is-visible-p date)
205	(list (list date string))))))))
206
207	(defun list-bahai-diary-entries ()
208	"Add any Baha'i date entries from the diary file to `diary-entries-list'.
209	Baha'i date diary entries must be prefaced by an
210	`bahai-diary-entry-symbol' (normally a `B'). The same diary date
211	forms govern the style of the Baha'i calendar entries, except that the
212	Baha'i month names must be given numerically. The Baha'i months are
213	numbered from 1 to 19 with Baha being 1 and 19 being `Ala. If a
214	Baha'i date diary entry begins with a `diary-nonmarking-symbol', the
215	entry will appear in the diary listing, but will not be marked in the
216	calendar. This function is provided for use with the
217	`nongregorian-diary-listing-hook'."
218	(if (< 0 number)
219	(let ((buffer-read-only nil)
220	(diary-modified (buffer-modified-p))
221	(gdate original-date)
222	(mark (regexp-quote diary-nonmarking-symbol)))
d7489fd9 GM	223	(dotimes (idummy number)
	224	(let* ((d diary-date-forms)
	225	(bdate (calendar-bahai-from-absolute
	226	(calendar-absolute-from-gregorian gdate)))
	227	(month (extract-calendar-month bdate))
	228	(day (extract-calendar-day bdate))
	229	(year (extract-calendar-year bdate)))
	230	(while d
	231	(let*
	232	((date-form (if (equal (car (car d)) 'backup)
	233	(cdr (car d))
	234	(car d)))
	235	(backup (equal (car (car d)) 'backup))
	236	(dayname
	237	(concat
	238	(calendar-day-name gdate) "\\\|"
	239	(substring (calendar-day-name gdate) 0 3) ".?"))
	240	(calendar-month-name-array
	241	bahai-calendar-month-name-array)
	242	(monthname
	243	(concat
	244	"\\*\\\|"
	245	(calendar-month-name month)))
	246	(month (concat "\\\\\|0" (int-to-string month)))
	247	(day (concat "\\\\\|0" (int-to-string day)))
	248	(year
	249	(concat
	250	"\\\\\|0" (int-to-string year)
	251	(if abbreviated-calendar-year
	252	(concat "\\\|" (int-to-string (% year 100)))
	253	"")))
	254	(regexp
	255	(concat
	256	"\\(\\`\\\|\^M\\\|\n\\)" mark "?"
	257	(regexp-quote bahai-diary-entry-symbol)
	258	"\\("
	259	(mapconcat 'eval date-form "\\)\\(")
	260	"\\)"))
	261	(case-fold-search t))
	262	(goto-char (point-min))
	263	(while (re-search-forward regexp nil t)
	264	(if backup (re-search-backward "\\<" nil t))
	265	(if (and (or (char-equal (preceding-char) ?\^M)
	266	(char-equal (preceding-char) ?\n))
	267	(not (looking-at " \\\|\^I")))
	268	;; Diary entry that consists only of date.
	269	(backward-char 1)
	270	;; Found a nonempty diary entry--make it visible and
	271	;; add it to the list.
	272	(let ((entry-start (point))
	273	(date-start))
	274	(re-search-backward "\^M\\\|\n\\\|\\`")
	275	(setq date-start (point))
	276	(re-search-forward "\^M\\\|\n" nil t 2)
	277	(while (looking-at " \\\|\^I")
	278	(re-search-forward "\^M\\\|\n" nil t))
	279	(backward-char 1)
	280	(subst-char-in-region date-start (point) ?\^M ?\n t)
	281	(add-to-diary-list
	282	gdate
	283	(buffer-substring-no-properties entry-start (point))
	284	(buffer-substring-no-properties
	285	(1+ date-start) (1- entry-start)))))))
	286	(setq d (cdr d))))
287	(setq gdate
288	(calendar-gregorian-from-absolute
289	(1+ (calendar-absolute-from-gregorian gdate)))))
290	(set-buffer-modified-p diary-modified))
291	(goto-char (point-min))))
811a8484 JW	292
	293	(defun mark-bahai-diary-entries ()
	294	"Mark days in the calendar window that have Baha'i date diary entries.
	295	Each entry in diary-file (or included files) visible in the calendar
	296	window is marked. Baha'i date entries are prefaced by a
	297	bahai-diary-entry-symbol \(normally a B`I'). The same
	298	diary-date-forms govern the style of the Baha'i calendar entries,
	299	except that the Baha'i month names must be spelled in full. The
	300	Baha'i months are numbered from 1 to 12 with Baha being 1 and 12 being
	301	`Ala. Baha'i date diary entries that begin with a
	302	diary-nonmarking-symbol will not be marked in the calendar. This
	303	function is provided for use as part of the
	304	nongregorian-diary-marking-hook."
	305	(let ((d diary-date-forms))
	306	(while d
	307	(let*
	308	((date-form (if (equal (car (car d)) 'backup)
	309	(cdr (car d))
	310	(car d)));; ignore 'backup directive
	311	(dayname (diary-name-pattern calendar-day-name-array))
	312	(monthname
	313	(concat
	314	(diary-name-pattern bahai-calendar-month-name-array t)
	315	"\\\|\\*"))
	316	(month "[0-9]+\\\|\\*")
	317	(day "[0-9]+\\\|\\*")
	318	(year "[0-9]+\\\|\\*")
	319	(l (length date-form))
	320	(d-name-pos (- l (length (memq 'dayname date-form))))
	321	(d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
	322	(m-name-pos (- l (length (memq 'monthname date-form))))
	323	(m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
	324	(d-pos (- l (length (memq 'day date-form))))
	325	(d-pos (if (/= l d-pos) (+ 2 d-pos)))
	326	(m-pos (- l (length (memq 'month date-form))))
	327	(m-pos (if (/= l m-pos) (+ 2 m-pos)))
	328	(y-pos (- l (length (memq 'year date-form))))
	329	(y-pos (if (/= l y-pos) (+ 2 y-pos)))
	330	(regexp
	331	(concat
	332	"\\(\\`\\\|\^M\\\|\n\\)"
	333	(regexp-quote bahai-diary-entry-symbol)
	334	"\\("
	335	(mapconcat 'eval date-form "\\)\\(")
	336	"\\)"))
	337	(case-fold-search t))
	338	(goto-char (point-min))
	339	(while (re-search-forward regexp nil t)
	340	(let* ((dd-name
	341	(if d-name-pos
	342	(buffer-substring
	343	(match-beginning d-name-pos)
	344	(match-end d-name-pos))))
	345	(mm-name
	346	(if m-name-pos
	347	(buffer-substring
	348	(match-beginning m-name-pos)
	349	(match-end m-name-pos))))
027a4b6b	350	(mm (string-to-number
811a8484 JW	351	(if m-pos
	352	(buffer-substring
	353	(match-beginning m-pos)
	354	(match-end m-pos))
	355	"")))
027a4b6b	356	(dd (string-to-number
811a8484 JW	357	(if d-pos
	358	(buffer-substring
	359	(match-beginning d-pos)
	360	(match-end d-pos))
	361	"")))
	362	(y-str (if y-pos
	363	(buffer-substring
	364	(match-beginning y-pos)
	365	(match-end y-pos))))
	366	(yy (if (not y-str)
	367	0
	368	(if (and (= (length y-str) 2)
	369	abbreviated-calendar-year)
	370	(let* ((current-y
	371	(extract-calendar-year
	372	(calendar-bahai-from-absolute
	373	(calendar-absolute-from-gregorian
	374	(calendar-current-date)))))
027a4b6b	375	(y (+ (string-to-number y-str)
811a8484 JW	376	(* 100 (/ current-y 100)))))
	377	(if (> (- y current-y) 50)
	378	(- y 100)
	379	(if (> (- current-y y) 50)
	380	(+ y 100)
	381	y)))
027a4b6b	382	(string-to-number y-str)))))
811a8484 JW	383	(if dd-name
811a8484 JW	384	(mark-calendar-days-named
59d8fe2e JB	385	(cdr (assoc-string (substring dd-name 0 3)
	386	(calendar-make-alist
	387	calendar-day-name-array
	388	0
	389	'(lambda (x) (substring x 0 3)))
	390	t)))
811a8484 JW	391	(if mm-name
	392	(if (string-equal mm-name "*")
	393	(setq mm 0)
	394	(setq mm
59d8fe2e	395	(cdr (assoc-string
811a8484 JW	396	mm-name
811a8484 JW	397	(calendar-make-alist
59d8fe2e JB	398	bahai-calendar-month-name-array)
59d8fe2e JB	399	t)))))
811a8484 JW	400	(mark-bahai-calendar-date-pattern mm dd yy)))))
	401	(setq d (cdr d)))))
	402
	403	(defun mark-bahai-calendar-date-pattern (month day year)
	404	"Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.
	405	A value of 0 in any position is a wildcard."
	406	(save-excursion
	407	(set-buffer calendar-buffer)
	408	(if (and (/= 0 month) (/= 0 day))
	409	(if (/= 0 year)
	410	;; Fully specified Baha'i date.
	411	(let ((date (calendar-gregorian-from-absolute
	412	(calendar-absolute-from-bahai
	413	(list month day year)))))
	414	(if (calendar-date-is-visible-p date)
	415	(mark-visible-calendar-date date)))
	416	;; Month and day in any year--this taken from the holiday stuff.
	417	(let* ((bahai-date (calendar-bahai-from-absolute
	418	(calendar-absolute-from-gregorian
	419	(list displayed-month 15 displayed-year))))
	420	(m (extract-calendar-month bahai-date))
	421	(y (extract-calendar-year bahai-date))
	422	(date))
	423	(if (< m 1)
	424	nil;; Baha'i calendar doesn't apply.
	425	(increment-calendar-month m y (- 10 month))
	426	(if (> m 7);; Baha'i date might be visible
	427	(let ((date (calendar-gregorian-from-absolute
	428	(calendar-absolute-from-bahai
	429	(list month day y)))))
	430	(if (calendar-date-is-visible-p date)
	431	(mark-visible-calendar-date date)))))))
	432	;; Not one of the simple cases--check all visible dates for match.
	433	;; Actually, the following code takes care of ALL of the cases, but
	434	;; it's much too slow to be used for the simple (common) cases.
	435	(let ((m displayed-month)
	436	(y displayed-year)
	437	(first-date)
	438	(last-date))
	439	(increment-calendar-month m y -1)
	440	(setq first-date
	441	(calendar-absolute-from-gregorian
	442	(list m 1 y)))
	443	(increment-calendar-month m y 2)
	444	(setq last-date
	445	(calendar-absolute-from-gregorian
	446	(list m (calendar-last-day-of-month m y) y)))
	447	(calendar-for-loop date from first-date to last-date do
	448	(let* ((b-date (calendar-bahai-from-absolute date))
	449	(i-month (extract-calendar-month b-date))
	450	(i-day (extract-calendar-day b-date))
	451	(i-year (extract-calendar-year b-date)))
	452	(and (or (zerop month)
	453	(= month i-month))
	454	(or (zerop day)
	455	(= day i-day))
	456	(or (zerop year)
	457	(= year i-year))
	458	(mark-visible-calendar-date
	459	(calendar-gregorian-from-absolute date)))))))))
	460
	461	(defun insert-bahai-diary-entry (arg)
	462	"Insert a diary entry.
	463	For the Baha'i date corresponding to the date indicated by point.
464	Prefix arg will make the entry nonmarking."
465	(interactive "P")
466	(let* ((calendar-month-name-array bahai-calendar-month-name-array))
467	(make-diary-entry
468	(concat
469	bahai-diary-entry-symbol
916f8173	470	(calendar-date-string
811a8484 JW	471	(calendar-bahai-from-absolute
	472	(calendar-absolute-from-gregorian
	473	(calendar-cursor-to-date t)))
	474	nil t))
	475	arg)))
	476
	477	(defun insert-monthly-bahai-diary-entry (arg)
	478	"Insert a monthly diary entry.
	479	For the day of the Baha'i month corresponding to the date indicated by point.
	480	Prefix arg will make the entry nonmarking."
	481	(interactive "P")
	482	(let* ((calendar-date-display-form
	483	(if european-calendar-style '(day " * ") '("* " day )))
	484	(calendar-month-name-array bahai-calendar-month-name-array))
	485	(make-diary-entry
	486	(concat
	487	bahai-diary-entry-symbol
916f8173	488	(calendar-date-string
811a8484 JW	489	(calendar-bahai-from-absolute
	490	(calendar-absolute-from-gregorian
	491	(calendar-cursor-to-date t)))))
	492	arg)))
	493
	494	(defun insert-yearly-bahai-diary-entry (arg)
	495	"Insert an annual diary entry.
	496	For the day of the Baha'i year corresponding to the date indicated by point.
	497	Prefix arg will make the entry nonmarking."
	498	(interactive "P")
	499	(let* ((calendar-date-display-form
	500	(if european-calendar-style
	501	'(day " " monthname)
	502	'(monthname " " day)))
	503	(calendar-month-name-array bahai-calendar-month-name-array))
	504	(make-diary-entry
	505	(concat
	506	bahai-diary-entry-symbol
916f8173	507	(calendar-date-string
811a8484 JW	508	(calendar-bahai-from-absolute
	509	(calendar-absolute-from-gregorian
	510	(calendar-cursor-to-date t)))))
	511	arg)))
	512
	513	(provide 'cal-bahai)
	514
88e15d0e	515	;;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
811a8484	516	;;; cal-bahai.el ends here