1 ;;; cal-bahai.el --- calendar functions for the Baha'i calendar.
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
5 ;; Author: John Wiegley <johnw@gnu.org>
7 ;; Human-Keywords: Baha'i calendar, Baha'i, Bahai, calendar, diary
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; This collection of functions implements the features of calendar.el
29 ;; and diary.el that deal with the Baha'i calendar.
31 ;; The Baha'i (http://www.bahai.org) calendar system is based on a
32 ;; solar cycle of 19 months with 19 days each. The four remaining
33 ;; "intercalary" days are called the Ayyam-i-Ha (days of Ha), and are
34 ;; placed between the 18th and 19th months. They are meant as a time
35 ;; of festivals preceding the 19th month, which is the month of
36 ;; fasting. In Gregorian leap years, there are 5 of these days (Ha
37 ;; has the numerical value of 5 in the arabic abjad, or
38 ;; letter-to-number, reckoning).
40 ;; Each month is named after an attribute of God, as are the 19 days
41 ;; -- which have the same names as the months. There is also a name
42 ;; for each year in every 19 year cycle. These cycles are called
43 ;; Vahids. A cycle of 19 Vahids (361 years) is called a Kullu-Shay,
44 ;; which means "all things".
46 ;; The calendar was named the "Badi calendar" by its author, the Bab.
47 ;; It uses a week of seven days, corresponding to the Gregorian week,
48 ;; each of which has its own name, again patterned after the
51 ;; Note: The days of Ayyam-i-Ha are encoded as zero and negative
52 ;; offsets from the first day of the final month. So, (19 -3 157) is
53 ;; the first day of Ayyam-i-Ha, in the year 157 BE.
59 (defvar bahai-calendar-month-name-array
60 ["Baha" "Jalal" "Jamal" "`Azamat" "Nur" "Rahmat" "Kalimat" "Kamal"
61 "Asma" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masa'il"
62 "Sharaf" "Sultan" "Mulk" "`Ala"])
64 (defvar calendar-bahai-epoch
(calendar-absolute-from-gregorian '(3 21 1844))
65 "Absolute date of start of Baha'i calendar = March 19, 622 A.D. (Julian).")
67 (defun bahai-calendar-leap-year-p (year)
68 "True if YEAR is a leap year on the Baha'i calendar."
69 (calendar-leap-year-p (+ year
1844)))
71 (defvar bahai-calendar-leap-base
72 (+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400)))
74 (defun calendar-absolute-from-bahai (date)
75 "Compute absolute date from Baha'i date DATE.
76 The absolute date is the number of days elapsed since the (imaginary)
77 Gregorian date Sunday, December 31, 1 BC."
78 (let* ((month (extract-calendar-month date
))
79 (day (extract-calendar-day date
))
80 (year (extract-calendar-year date
))
81 (prior-years (+ (1- year
) 1844))
82 (leap-days (- (+ (/ prior-years
4) ; Leap days in prior years.
83 (- (/ prior-years
100))
85 bahai-calendar-leap-base
)))
86 (+ (1- calendar-bahai-epoch
) ; Days before epoch
87 (* 365 (1- year
)) ; Days in prior years.
89 (calendar-sum m
1 (< m month
) 19)
91 day
))) ; Days so far this month.
93 (defun calendar-bahai-from-absolute (date)
94 "Baha'i year corresponding to the absolute DATE."
95 (if (< date calendar-bahai-epoch
)
96 (list 0 0 0) ;; pre-Baha'i date
97 (let* ((greg (calendar-gregorian-from-absolute date
))
98 (year (+ (- (extract-calendar-year greg
) 1844)
99 (if (or (> (extract-calendar-month greg
) 3)
100 (and (= (extract-calendar-month greg
) 3)
101 (>= (extract-calendar-day greg
) 21)))
103 (month ;; Search forward from Baha.
104 (1+ (calendar-sum m
1
106 (calendar-absolute-from-bahai
109 (day ;; Calculate the day by subtraction.
111 (1- (calendar-absolute-from-bahai (list month
1 year
))))))
112 (list month day year
))))
114 (defun calendar-bahai-date-string (&optional date
)
115 "String of Baha'i date of Gregorian DATE.
116 Defaults to today's date if DATE is not given."
117 (let* ((bahai-date (calendar-bahai-from-absolute
118 (calendar-absolute-from-gregorian
119 (or date
(calendar-current-date)))))
120 (y (extract-calendar-year bahai-date
))
121 (m (extract-calendar-month bahai-date
))
122 (d (extract-calendar-day bahai-date
)))
127 (aref bahai-calendar-month-name-array
(1- m
))))
130 (if (bahai-calendar-leap-year-p y
)
135 (month (int-to-string m
))
136 (year (int-to-string y
)))
137 (mapconcat 'eval calendar-date-display-form
""))))
139 (defun calendar-print-bahai-date ()
140 "Show the Baha'i calendar equivalent of the selected date."
142 (message "Baha'i date: %s"
143 (calendar-bahai-date-string (calendar-cursor-to-date t
))))
145 (defun calendar-goto-bahai-date (date &optional noecho
)
146 "Move cursor to Baha'i date DATE.
147 Echo Baha'i date unless NOECHO is t."
148 (interactive (bahai-prompt-for-date))
149 (calendar-goto-date (calendar-gregorian-from-absolute
150 (calendar-absolute-from-bahai date
)))
151 (or noecho
(calendar-print-bahai-date)))
153 (defun bahai-prompt-for-date ()
154 "Ask for a Baha'i date."
155 (let* ((today (calendar-current-date))
157 "Baha'i calendar year (not 0): "
158 '(lambda (x) (/= x
0))
160 (extract-calendar-year
161 (calendar-bahai-from-absolute
162 (calendar-absolute-from-gregorian today
))))))
163 (completion-ignore-case t
)
166 "Baha'i calendar month name: "
168 (append bahai-calendar-month-name-array nil
))
170 (calendar-make-alist bahai-calendar-month-name-array
172 (day (calendar-read "Baha'i calendar day (1-19): "
173 '(lambda (x) (and (< 0 x
) (<= x
19))))))
174 (list (list month day year
))))
176 (defun diary-bahai-date ()
177 "Baha'i calendar equivalent of date diary entry."
178 (format "Baha'i date: %s" (calendar-bahai-date-string date
)))
180 (defun holiday-bahai (month day string
)
181 "Holiday on MONTH, DAY (Baha'i) called STRING.
182 If MONTH, DAY (Baha'i) is visible, the value returned is corresponding
183 Gregorian date in the form of the list (((month day year) STRING)). Returns
184 nil if it is not visible in the current calendar window."
185 (let* ((bahai-date (calendar-bahai-from-absolute
186 (calendar-absolute-from-gregorian
187 (list displayed-month
15 displayed-year
))))
188 (m (extract-calendar-month bahai-date
))
189 (y (extract-calendar-year bahai-date
))
192 nil
;; Baha'i calendar doesn't apply.
193 (increment-calendar-month m y
(- 10 month
))
194 (if (> m
7) ;; Baha'i date might be visible
195 (let ((date (calendar-gregorian-from-absolute
196 (calendar-absolute-from-bahai (list month day y
)))))
197 (if (calendar-date-is-visible-p date
)
198 (list (list date string
))))))))
200 (defun list-bahai-diary-entries ()
201 "Add any Baha'i date entries from the diary file to `diary-entries-list'.
202 Baha'i date diary entries must be prefaced by an
203 `bahai-diary-entry-symbol' (normally a `B'). The same diary date
204 forms govern the style of the Baha'i calendar entries, except that the
205 Baha'i month names must be given numerically. The Baha'i months are
206 numbered from 1 to 19 with Baha being 1 and 19 being `Ala. If a
207 Baha'i date diary entry begins with a `diary-nonmarking-symbol', the
208 entry will appear in the diary listing, but will not be marked in the
209 calendar. This function is provided for use with the
210 `nongregorian-diary-listing-hook'."
212 (let ((buffer-read-only nil
)
213 (diary-modified (buffer-modified-p))
214 (gdate original-date
)
215 (mark (regexp-quote diary-nonmarking-symbol
)))
216 (calendar-for-loop i from
1 to number do
217 (let* ((d diary-date-forms
)
218 (bdate (calendar-bahai-from-absolute
219 (calendar-absolute-from-gregorian gdate
)))
220 (month (extract-calendar-month bdate
))
221 (day (extract-calendar-day bdate
))
222 (year (extract-calendar-year bdate
)))
225 ((date-form (if (equal (car (car d
)) 'backup
)
228 (backup (equal (car (car d
)) 'backup
))
231 (calendar-day-name gdate
) "\\|"
232 (substring (calendar-day-name gdate
) 0 3) ".?"))
233 (calendar-month-name-array
234 bahai-calendar-month-name-array
)
238 (calendar-month-name month
)))
239 (month (concat "\\*\\|0*" (int-to-string month
)))
240 (day (concat "\\*\\|0*" (int-to-string day
)))
243 "\\*\\|0*" (int-to-string year
)
244 (if abbreviated-calendar-year
245 (concat "\\|" (int-to-string (% year
100)))
249 "\\(\\`\\|\^M\\|\n\\)" mark
"?"
250 (regexp-quote bahai-diary-entry-symbol
)
252 (mapconcat 'eval date-form
"\\)\\(")
254 (case-fold-search t
))
255 (goto-char (point-min))
256 (while (re-search-forward regexp nil t
)
257 (if backup
(re-search-backward "\\<" nil t
))
258 (if (and (or (char-equal (preceding-char) ?\^M
)
259 (char-equal (preceding-char) ?
\n))
260 (not (looking-at " \\|\^I")))
261 ;; Diary entry that consists only of date.
263 ;; Found a nonempty diary entry--make it visible and
264 ;; add it to the list.
265 (let ((entry-start (point))
267 (re-search-backward "\^M\\|\n\\|\\`")
268 (setq date-start
(point))
269 (re-search-forward "\^M\\|\n" nil t
2)
270 (while (looking-at " \\|\^I")
271 (re-search-forward "\^M\\|\n" nil t
))
273 (subst-char-in-region date-start
(point) ?\^M ?
\n t
)
276 (buffer-substring-no-properties entry-start
(point))
277 (buffer-substring-no-properties
278 (1+ date-start
) (1- entry-start
)))))))
281 (calendar-gregorian-from-absolute
282 (1+ (calendar-absolute-from-gregorian gdate
)))))
283 (set-buffer-modified-p diary-modified
))
284 (goto-char (point-min))))
286 (defun mark-bahai-diary-entries ()
287 "Mark days in the calendar window that have Baha'i date diary entries.
288 Each entry in diary-file (or included files) visible in the calendar
289 window is marked. Baha'i date entries are prefaced by a
290 bahai-diary-entry-symbol \(normally a B`I'). The same
291 diary-date-forms govern the style of the Baha'i calendar entries,
292 except that the Baha'i month names must be spelled in full. The
293 Baha'i months are numbered from 1 to 12 with Baha being 1 and 12 being
294 `Ala. Baha'i date diary entries that begin with a
295 diary-nonmarking-symbol will not be marked in the calendar. This
296 function is provided for use as part of the
297 nongregorian-diary-marking-hook."
298 (let ((d diary-date-forms
))
301 ((date-form (if (equal (car (car d
)) 'backup
)
303 (car d
)));; ignore 'backup directive
304 (dayname (diary-name-pattern calendar-day-name-array
))
307 (diary-name-pattern bahai-calendar-month-name-array t
)
309 (month "[0-9]+\\|\\*")
311 (year "[0-9]+\\|\\*")
312 (l (length date-form
))
313 (d-name-pos (- l
(length (memq 'dayname date-form
))))
314 (d-name-pos (if (/= l d-name-pos
) (+ 2 d-name-pos
)))
315 (m-name-pos (- l
(length (memq 'monthname date-form
))))
316 (m-name-pos (if (/= l m-name-pos
) (+ 2 m-name-pos
)))
317 (d-pos (- l
(length (memq 'day date-form
))))
318 (d-pos (if (/= l d-pos
) (+ 2 d-pos
)))
319 (m-pos (- l
(length (memq 'month date-form
))))
320 (m-pos (if (/= l m-pos
) (+ 2 m-pos
)))
321 (y-pos (- l
(length (memq 'year date-form
))))
322 (y-pos (if (/= l y-pos
) (+ 2 y-pos
)))
325 "\\(\\`\\|\^M\\|\n\\)"
326 (regexp-quote bahai-diary-entry-symbol
)
328 (mapconcat 'eval date-form
"\\)\\(")
330 (case-fold-search t
))
331 (goto-char (point-min))
332 (while (re-search-forward regexp nil t
)
336 (match-beginning d-name-pos
)
337 (match-end d-name-pos
))))
341 (match-beginning m-name-pos
)
342 (match-end m-name-pos
))))
343 (mm (string-to-number
346 (match-beginning m-pos
)
349 (dd (string-to-number
352 (match-beginning d-pos
)
357 (match-beginning y-pos
)
361 (if (and (= (length y-str
) 2)
362 abbreviated-calendar-year
)
364 (extract-calendar-year
365 (calendar-bahai-from-absolute
366 (calendar-absolute-from-gregorian
367 (calendar-current-date)))))
368 (y (+ (string-to-number y-str
)
369 (* 100 (/ current-y
100)))))
370 (if (> (- y current-y
) 50)
372 (if (> (- current-y y
) 50)
375 (string-to-number y-str
)))))
377 (mark-calendar-days-named
378 (cdr (assoc-string (substring dd-name
0 3)
380 calendar-day-name-array
382 '(lambda (x) (substring x
0 3)))
385 (if (string-equal mm-name
"*")
391 bahai-calendar-month-name-array
)
393 (mark-bahai-calendar-date-pattern mm dd yy
)))))
396 (defun mark-bahai-calendar-date-pattern (month day year
)
397 "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.
398 A value of 0 in any position is a wildcard."
400 (set-buffer calendar-buffer
)
401 (if (and (/= 0 month
) (/= 0 day
))
403 ;; Fully specified Baha'i date.
404 (let ((date (calendar-gregorian-from-absolute
405 (calendar-absolute-from-bahai
406 (list month day year
)))))
407 (if (calendar-date-is-visible-p date
)
408 (mark-visible-calendar-date date
)))
409 ;; Month and day in any year--this taken from the holiday stuff.
410 (let* ((bahai-date (calendar-bahai-from-absolute
411 (calendar-absolute-from-gregorian
412 (list displayed-month
15 displayed-year
))))
413 (m (extract-calendar-month bahai-date
))
414 (y (extract-calendar-year bahai-date
))
417 nil
;; Baha'i calendar doesn't apply.
418 (increment-calendar-month m y
(- 10 month
))
419 (if (> m
7);; Baha'i date might be visible
420 (let ((date (calendar-gregorian-from-absolute
421 (calendar-absolute-from-bahai
422 (list month day y
)))))
423 (if (calendar-date-is-visible-p date
)
424 (mark-visible-calendar-date date
)))))))
425 ;; Not one of the simple cases--check all visible dates for match.
426 ;; Actually, the following code takes care of ALL of the cases, but
427 ;; it's much too slow to be used for the simple (common) cases.
428 (let ((m displayed-month
)
432 (increment-calendar-month m y -
1)
434 (calendar-absolute-from-gregorian
436 (increment-calendar-month m y
2)
438 (calendar-absolute-from-gregorian
439 (list m
(calendar-last-day-of-month m y
) y
)))
440 (calendar-for-loop date from first-date to last-date do
441 (let* ((b-date (calendar-bahai-from-absolute date
))
442 (i-month (extract-calendar-month b-date
))
443 (i-day (extract-calendar-day b-date
))
444 (i-year (extract-calendar-year b-date
)))
445 (and (or (zerop month
)
451 (mark-visible-calendar-date
452 (calendar-gregorian-from-absolute date
)))))))))
454 (defun insert-bahai-diary-entry (arg)
455 "Insert a diary entry.
456 For the Baha'i date corresponding to the date indicated by point.
457 Prefix arg will make the entry nonmarking."
459 (let* ((calendar-month-name-array bahai-calendar-month-name-array
))
462 bahai-diary-entry-symbol
463 (calendar-date-string
464 (calendar-bahai-from-absolute
465 (calendar-absolute-from-gregorian
466 (calendar-cursor-to-date t
)))
470 (defun insert-monthly-bahai-diary-entry (arg)
471 "Insert a monthly diary entry.
472 For the day of the Baha'i month corresponding to the date indicated by point.
473 Prefix arg will make the entry nonmarking."
475 (let* ((calendar-date-display-form
476 (if european-calendar-style
'(day " * ") '("* " day
)))
477 (calendar-month-name-array bahai-calendar-month-name-array
))
480 bahai-diary-entry-symbol
481 (calendar-date-string
482 (calendar-bahai-from-absolute
483 (calendar-absolute-from-gregorian
484 (calendar-cursor-to-date t
)))))
487 (defun insert-yearly-bahai-diary-entry (arg)
488 "Insert an annual diary entry.
489 For the day of the Baha'i year corresponding to the date indicated by point.
490 Prefix arg will make the entry nonmarking."
492 (let* ((calendar-date-display-form
493 (if european-calendar-style
495 '(monthname " " day
)))
496 (calendar-month-name-array bahai-calendar-month-name-array
))
499 bahai-diary-entry-symbol
500 (calendar-date-string
501 (calendar-bahai-from-absolute
502 (calendar-absolute-from-gregorian
503 (calendar-cursor-to-date t
)))))
508 ;;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
509 ;;; cal-bahai.el ends here