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

;;; cal-bahai.el --- calendar functions for the Bahá'í calendar. -*- coding: utf-8 -*-

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

;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Bahá'í calendar, Bahá'í, 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 Bahá'í calendar.

;; The Bahá'í (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 Ayyám-i-Há (days of Há), 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 (Há
;; 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
;; Váhids.  A cycle of 19 Váhids (361 years) is called a Kullu-Shay,
;; which means "all things".

;; The calendar was named the "Badí` calendar" by its author, the Báb.
;; 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 Ayyám-i-Há are encoded as zero and negative
;; offsets from the first day of the final month.  So, (19 -3 157) is
;; the first day of Ayyám-i-Há, in the year 157 BE.

;;; Code:

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

(require 'cal-julian)

(defconst calendar-bahai-month-name-array
  ["Bahá" "Jalál" "Jamál" "`Azamat" "Núr" "Rahmat" "Kalimát" "Kamál"
   "Asmá" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masá'il"
   "Sharaf" "Sultán" "Mulk" "`Alá"])

(defconst calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844))
  "Absolute date of start of Bahá'í calendar = March 19, 622 A.D. (Julian).")

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

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

(defun calendar-absolute-from-bahai (date)
  "Compute absolute date from Bahá'í 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))
		       calendar-bahai-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)
  "Bahá'í year corresponding to the absolute DATE."
  (if (< date calendar-bahai-epoch)
      (list 0 0 0) ;; pre-Bahá'í 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 Bahá'í 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))
	       "Ayyám-i-Há"
	     (aref calendar-bahai-month-name-array (1- m))))
	  (day (int-to-string
		(if (<= d 0)
		    (if (calendar-bahai-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 Bahá'í calendar equivalent of the selected date."
  (interactive)
  (message "Bahá'í date: %s"
           (calendar-bahai-date-string (calendar-cursor-to-date t))))

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

(defun calendar-bahai-prompt-for-date ()
  "Ask for a Bahá'í date."
  (let* ((today (calendar-current-date))
         (year (calendar-read
                "Bahá'í 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
                        "Bahá'í calendar month name: "
                        (mapcar 'list
                                (append calendar-bahai-month-name-array nil))
                        nil t)
                      (calendar-make-alist calendar-bahai-month-name-array
                                           1))))
         (day (calendar-read "Bahá'í calendar day (1-19): "
			     '(lambda (x) (and (< 0 x) (<= x 19))))))
    (list (list month day year))))

(defun diary-bahai-date ()
  "Bahá'í calendar equivalent of date diary entry."
  (format "Bahá'í date: %s" (calendar-bahai-date-string date)))

(defun holiday-bahai (month day string)
  "Holiday on MONTH, DAY (Bahá'í) called STRING.
If MONTH, DAY (Bahá'í) 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 ;;   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)
                (list (list date string))))))))

(defun diary-list-bahai-entries ()
  "Add any Bahá'í date entries from the diary file to `diary-entries-list'.
Bahá'í 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 Bahá'í calendar entries, except that the
Bahá'í month names must be given numerically.  The Bahá'í months are
numbered from 1 to 19 with Bahá being 1 and 19 being `Alá.  If a
Bahá'í 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
                    calendar-bahai-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 diary-bahai-mark-entries ()
  "Mark days in the calendar window that have Bahá'í date diary entries.
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)))))))))

(defun diary-insert-bahai-entry (arg)
  "Insert a diary entry.
For the Bahá'í date corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
  (interactive "P")
  (let* ((calendar-month-name-array calendar-bahai-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 diary-bahai-insert-monthly-entry (arg)
  "Insert a monthly diary entry.
For the day of the Bahá'í 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 calendar-bahai-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 diary-bahai-insert-yearly-entry (arg)
  "Insert an annual diary entry.
For the day of the Bahá'í 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 calendar-bahai-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)))

;; Backward compatibility.
(define-obsolete-function-alias
  'list-bahai-diary-entries 'diary-list-bahai-entries "23.1")
(define-obsolete-function-alias
  'mark-bahai-diary-entries 'diary-mark-bahai-entries "23.1")
(define-obsolete-function-alias
  'insert-bahai-diary-entry 'diary-insert-bahai-entry "23.1")
(define-obsolete-function-alias
  'insert-monthly-bahai-diary-entry 'diary-insert-bahai-monthly-entry "23.1")
(define-obsolete-function-alias
  'insert-yearly-bahai-diary-entry 'diary-insert-bahai-yearly-entry "23.1")
(define-obsolete-function-alias
  'mark-bahai-calendar-date-pattern 'calendar-bahai-mark-date-pattern "23.1")

(provide 'cal-bahai)

;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
;;; cal-bahai.el ends here
Commit	Line	Data
86831703	1	;;; cal-bahai.el --- calendar functions for the Bahá'í calendar. -- coding: utf-8 --
811a8484	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
305c237c	8	;; Human-Keywords: Bahá'í calendar, Bahá'í, Baha'i, Bahai, calendar, diary
811a8484 JW	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
305c237c	30	;; and diary.el that deal with the Bahá'í calendar.
811a8484	31
305c237c	32	;; The Bahá'í (http://www.bahai.org) calendar system is based on a
811a8484	33	;; solar cycle of 19 months with 19 days each. The four remaining
305c237c	34	;; "intercalary" days are called the Ayyám-i-Há (days of Há), and are
811a8484 JW	35	;; placed between the 18th and 19th months. They are meant as a time
811a8484 JW	36	;; of festivals preceding the 19th month, which is the month of
305c237c	37	;; fasting. In Gregorian leap years, there are 5 of these days (Há
811a8484 JW	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
305c237c	44	;; Váhids. A cycle of 19 Váhids (361 years) is called a Kullu-Shay,
811a8484 JW	45	;; which means "all things".
811a8484 JW	46
305c237c	47	;; The calendar was named the "Badí` calendar" by its author, the Báb.
811a8484 JW	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
305c237c	52	;; Note: The days of Ayyám-i-Há are encoded as zero and negative
811a8484	53	;; offsets from the first day of the final month. So, (19 -3 157) is
305c237c	54	;; the first day of Ayyám-i-Há, in the year 157 BE.
811a8484 JW	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)
811a8484 JW	65
e4e1cf95	66	(defconst calendar-bahai-month-name-array
305c237c JW	67	["Bahá" "Jalál" "Jamál" "`Azamat" "Núr" "Rahmat" "Kalimát" "Kamál"
	68	"Asmá" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masá'il"
	69	"Sharaf" "Sultán" "Mulk" "`Alá"])
811a8484	70
e4e1cf95	71	(defconst calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844))
305c237c	72	"Absolute date of start of Bahá'í calendar = March 19, 622 A.D. (Julian).")
811a8484	73
e4e1cf95	74	(defun calendar-bahai-leap-year-p (year)
305c237c	75	"True if YEAR is a leap year on the Bahá'í calendar."
811a8484 JW	76	(calendar-leap-year-p (+ year 1844)))
811a8484 JW	77
e4e1cf95	78	(defconst calendar-bahai-leap-base
811a8484 JW	79	(+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400)))
	80
	81	(defun calendar-absolute-from-bahai (date)
305c237c	82	"Compute absolute date from Bahá'í date DATE.
811a8484 JW	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))
e4e1cf95	92	calendar-bahai-leap-base)))
811a8484 JW	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)
305c237c	101	"Bahá'í year corresponding to the absolute DATE."
811a8484	102	(if (< date calendar-bahai-epoch)
305c237c	103	(list 0 0 0) ;; pre-Bahá'í date
811a8484 JW	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)
305c237c	122	"String of Bahá'í date of Gregorian DATE.
811a8484 JW	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))
305c237c	133	"Ayyám-i-Há"
e4e1cf95	134	(aref calendar-bahai-month-name-array (1- m))))
811a8484 JW	135	(day (int-to-string
811a8484 JW	136	(if (<= d 0)
e4e1cf95	137	(if (calendar-bahai-leap-year-p y)
811a8484 JW	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 ()
305c237c	147	"Show the Bahá'í calendar equivalent of the selected date."
811a8484	148	(interactive)
305c237c	149	(message "Bahá'í date: %s"
811a8484 JW	150	(calendar-bahai-date-string (calendar-cursor-to-date t))))
	151
	152	(defun calendar-goto-bahai-date (date &optional noecho)
305c237c JW	153	"Move cursor to Bahá'í date DATE.
305c237c JW	154	Echo Bahá'í date unless NOECHO is t."
e4e1cf95	155	(interactive (calendar-bahai-prompt-for-date))
811a8484 JW	156	(calendar-goto-date (calendar-gregorian-from-absolute
	157	(calendar-absolute-from-bahai date)))
	158	(or noecho (calendar-print-bahai-date)))
	159
e4e1cf95	160	(defun calendar-bahai-prompt-for-date ()
305c237c	161	"Ask for a Bahá'í date."
811a8484 JW	162	(let* ((today (calendar-current-date))
811a8484 JW	163	(year (calendar-read
305c237c	164	"Bahá'í calendar year (not 0): "
811a8484 JW	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
305c237c	173	"Bahá'í calendar month name: "
811a8484	174	(mapcar 'list
e4e1cf95	175	(append calendar-bahai-month-name-array nil))
811a8484	176	nil t)
e4e1cf95	177	(calendar-make-alist calendar-bahai-month-name-array
811a8484	178	1))))
305c237c	179	(day (calendar-read "Bahá'í calendar day (1-19): "
811a8484 JW	180	'(lambda (x) (and (< 0 x) (<= x 19))))))
	181	(list (list month day year))))
	182
	183	(defun diary-bahai-date ()
305c237c JW	184	"Bahá'í calendar equivalent of date diary entry."
305c237c JW	185	(format "Bahá'í date: %s" (calendar-bahai-date-string date)))
811a8484 JW	186
811a8484 JW	187	(defun holiday-bahai (month day string)
305c237c JW	188	"Holiday on MONTH, DAY (Bahá'í) called STRING.
305c237c JW	189	If MONTH, DAY (Bahá'í) is visible, the value returned is corresponding
811a8484 JW	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)
305c237c	199	nil ;; Bahá'í calendar doesn't apply.
811a8484	200	(increment-calendar-month m y (- 10 month))
305c237c	201	(if (> m 7) ;; Bahá'í date might be visible
811a8484 JW	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
e4e1cf95	207	(defun diary-list-bahai-entries ()
305c237c JW	208	"Add any Bahá'í date entries from the diary file to `diary-entries-list'.
305c237c JW	209	Bahá'í date diary entries must be prefaced by an
811a8484	210	`bahai-diary-entry-symbol' (normally a `B'). The same diary date
305c237c JW	211	forms govern the style of the Bahá'í calendar entries, except that the
	212	Bahá'í month names must be given numerically. The Bahá'í months are
	213	numbered from 1 to 19 with Bahá being 1 and 19 being `Alá. If a
	214	Bahá'í date diary entry begins with a `diary-nonmarking-symbol', the
811a8484 JW	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
e4e1cf95	241	calendar-bahai-month-name-array)
d7489fd9 GM	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	292
e4e1cf95	293	(defun diary-bahai-mark-entries ()
305c237c	294	"Mark days in the calendar window that have Bahá'í date diary entries.
811a8484	295	Each entry in diary-file (or included files) visible in the calendar
305c237c	296	window is marked. Bahá'í date entries are prefaced by a
811a8484	297	bahai-diary-entry-symbol \(normally a B`I'). The same
305c237c JW	298	diary-date-forms govern the style of the Bahá'í calendar entries,
	299	except that the Bahá'í month names must be spelled in full. The
	300	Bahá'í months are numbered from 1 to 12 with Bahá being 1 and 12 being
	301	`Alá. Bahá'í date diary entries that begin with a
811a8484 JW	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
e4e1cf95	314	(diary-name-pattern calendar-bahai-month-name-array t)
811a8484 JW	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
e4e1cf95	398	calendar-bahai-month-name-array)
59d8fe2e	399	t)))))
e4e1cf95	400	(calendar-bahai-mark-date-pattern mm dd yy)))))
811a8484 JW	401	(setq d (cdr d)))))
811a8484 JW	402
e4e1cf95	403	(defun calendar-bahai-mark-date-pattern (month day year)
305c237c	404	"Mark dates in calendar window that conform to Bahá'í date MONTH/DAY/YEAR.
811a8484 JW	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)
305c237c	410	;; Fully specified Bahá'í date.
811a8484 JW	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)
305c237c	424	nil;; Bahá'í calendar doesn't apply.
811a8484	425	(increment-calendar-month m y (- 10 month))
305c237c	426	(if (> m 7);; Bahá'í date might be visible
811a8484 JW	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
e4e1cf95	461	(defun diary-insert-bahai-entry (arg)
811a8484	462	"Insert a diary entry.
305c237c	463	For the Bahá'í date corresponding to the date indicated by point.
811a8484 JW	464	Prefix arg will make the entry nonmarking."
811a8484 JW	465	(interactive "P")
e4e1cf95	466	(let* ((calendar-month-name-array calendar-bahai-month-name-array))
811a8484 JW	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
e4e1cf95	477	(defun diary-bahai-insert-monthly-entry (arg)
811a8484	478	"Insert a monthly diary entry.
305c237c	479	For the day of the Bahá'í month corresponding to the date indicated by point.
811a8484 JW	480	Prefix arg will make the entry nonmarking."
	481	(interactive "P")
	482	(let* ((calendar-date-display-form
	483	(if european-calendar-style '(day " * ") '("* " day )))
e4e1cf95	484	(calendar-month-name-array calendar-bahai-month-name-array))
811a8484 JW	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
e4e1cf95	494	(defun diary-bahai-insert-yearly-entry (arg)
811a8484	495	"Insert an annual diary entry.
305c237c	496	For the day of the Bahá'í year corresponding to the date indicated by point.
811a8484 JW	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)))
e4e1cf95	503	(calendar-month-name-array calendar-bahai-month-name-array))
811a8484 JW	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
e4e1cf95 SM	513	;; Backward compatibility.
	514	(define-obsolete-function-alias
	515	'list-bahai-diary-entries 'diary-list-bahai-entries "23.1")
	516	(define-obsolete-function-alias
	517	'mark-bahai-diary-entries 'diary-mark-bahai-entries "23.1")
	518	(define-obsolete-function-alias
	519	'insert-bahai-diary-entry 'diary-insert-bahai-entry "23.1")
	520	(define-obsolete-function-alias
	521	'insert-monthly-bahai-diary-entry 'diary-insert-bahai-monthly-entry "23.1")
	522	(define-obsolete-function-alias
	523	'insert-yearly-bahai-diary-entry 'diary-insert-bahai-yearly-entry "23.1")
	524	(define-obsolete-function-alias
	525	'mark-bahai-calendar-date-pattern 'calendar-bahai-mark-date-pattern "23.1")
	526
811a8484 JW	527	(provide 'cal-bahai)
811a8484 JW	528
e4e1cf95	529	;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
811a8484	530	;;; cal-bahai.el ends here