| 1 | ;;; cal-bahai.el --- calendar functions for the Bahá'í calendar. |
| 2 | |
| 3 | ;; Copyright (C) 2001-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: John Wiegley <johnw@gnu.org> |
| 6 | ;; Keywords: calendar |
| 7 | ;; Human-Keywords: Bahá'í calendar, Bahá'í, Baha'i, Bahai, calendar, diary |
| 8 | ;; Package: calendar |
| 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 |
| 14 | ;; the Free Software Foundation, either version 3 of the License, or |
| 15 | ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;; This collection of functions implements the features of calendar.el |
| 28 | ;; and diary-lib.el that deal with the Bahá'í calendar. |
| 29 | |
| 30 | ;; The Bahá'í (http://www.bahai.org) calendar system is based on a |
| 31 | ;; solar cycle of 19 months with 19 days each. The four remaining |
| 32 | ;; "intercalary" days are called the Ayyám-i-Há (days of Há), and are |
| 33 | ;; placed between the 18th and 19th months. They are meant as a time |
| 34 | ;; of festivals preceding the 19th month, which is the month of |
| 35 | ;; fasting. In Gregorian leap years, there are 5 of these days (Há |
| 36 | ;; has the numerical value of 5 in the arabic abjad, or |
| 37 | ;; letter-to-number, reckoning). |
| 38 | |
| 39 | ;; Each month is named after an attribute of God, as are the 19 days |
| 40 | ;; -- which have the same names as the months. There is also a name |
| 41 | ;; for each year in every 19 year cycle. These cycles are called |
| 42 | ;; Váhids. A cycle of 19 Váhids (361 years) is called a Kullu-Shay, |
| 43 | ;; which means "all things". |
| 44 | |
| 45 | ;; The calendar was named the "Badí` calendar" by its author, the Báb. |
| 46 | ;; It uses a week of seven days, corresponding to the Gregorian week, |
| 47 | ;; each of which has its own name, again patterned after the |
| 48 | ;; attributes of God. |
| 49 | |
| 50 | ;; Note: The days of Ayyám-i-Há are encoded as zero and negative |
| 51 | ;; offsets from the first day of the final month. So, (19 -3 157) is |
| 52 | ;; the first day of Ayyám-i-Há, in the year 157 BE. |
| 53 | |
| 54 | ;;; Code: |
| 55 | |
| 56 | (require 'calendar) |
| 57 | |
| 58 | (defconst calendar-bahai-month-name-array |
| 59 | ["Bahá" "Jalál" "Jamál" "`Azamat" "Núr" "Rahmat" "Kalimát" "Kamál" |
| 60 | "Asmá" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masá'il" |
| 61 | "Sharaf" "Sultán" "Mulk" "`Alá"] |
| 62 | "Array of the month names in the Bahá'í calendar.") |
| 63 | |
| 64 | (defconst calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844)) |
| 65 | "Absolute date of start of Bahá'í calendar = March 21, 1844 AD.") |
| 66 | |
| 67 | (defun calendar-bahai-leap-year-p (year) |
| 68 | "True if Bahá'í YEAR is a leap year in the Bahá'í calendar." |
| 69 | (calendar-leap-year-p (+ year 1844))) |
| 70 | |
| 71 | (defconst calendar-bahai-leap-base |
| 72 | (+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400)) |
| 73 | "Number of leap years between 1 and 1844 AD, inclusive. |
| 74 | Used by `calendar-bahai-to-absolute'.") |
| 75 | |
| 76 | (defun calendar-bahai-to-absolute (date) |
| 77 | "Compute absolute date from Bahá'í date DATE. |
| 78 | The absolute date is the number of days elapsed since the (imaginary) |
| 79 | Gregorian date Sunday, December 31, 1 BC." |
| 80 | (let* ((month (calendar-extract-month date)) |
| 81 | (day (calendar-extract-day date)) |
| 82 | (year (calendar-extract-year date)) |
| 83 | (prior-years (+ (1- year) 1844)) |
| 84 | (leap-days (- (+ (/ prior-years 4) ; leap days in prior years |
| 85 | (- (/ prior-years 100)) |
| 86 | (/ prior-years 400)) |
| 87 | calendar-bahai-leap-base))) |
| 88 | (+ (1- calendar-bahai-epoch) ; days before epoch |
| 89 | (* 365 (1- year)) ; days in prior years |
| 90 | leap-days |
| 91 | (calendar-sum m 1 (< m month) 19) |
| 92 | (if (= month 19) |
| 93 | (if (calendar-bahai-leap-year-p year) 5 4) |
| 94 | 0) |
| 95 | day))) ; days so far this month |
| 96 | |
| 97 | (define-obsolete-function-alias 'calendar-absolute-from-bahai |
| 98 | 'calendar-bahai-to-absolute "23.1") |
| 99 | |
| 100 | (defun calendar-bahai-from-absolute (date) |
| 101 | "Bahá'í date (month day year) corresponding to the absolute DATE." |
| 102 | (if (< date calendar-bahai-epoch) |
| 103 | (list 0 0 0) ; pre-Bahá'í date |
| 104 | (let* ((greg (calendar-gregorian-from-absolute date)) |
| 105 | (gmonth (calendar-extract-month greg)) |
| 106 | (year (+ (- (calendar-extract-year greg) 1844) |
| 107 | (if (or (> gmonth 3) |
| 108 | (and (= gmonth 3) |
| 109 | (>= (calendar-extract-day greg) 21))) |
| 110 | 1 0))) |
| 111 | (month ; search forward from Baha |
| 112 | (1+ (calendar-sum m 1 |
| 113 | (> date (calendar-bahai-to-absolute (list m 19 year))) |
| 114 | 1))) |
| 115 | (day ; calculate the day by subtraction |
| 116 | (- date |
| 117 | (1- (calendar-bahai-to-absolute (list month 1 year)))))) |
| 118 | (list month day year)))) |
| 119 | |
| 120 | ;;;###cal-autoload |
| 121 | (defun calendar-bahai-date-string (&optional date) |
| 122 | "String of Bahá'í 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 (calendar-extract-year bahai-date))) |
| 128 | (if (< y 1) |
| 129 | "" ; pre-Bahai |
| 130 | (let* ((m (calendar-extract-month bahai-date)) |
| 131 | (d (calendar-extract-day bahai-date)) |
| 132 | (monthname (if (and (= m 19) |
| 133 | (<= d 0)) |
| 134 | "Ayyám-i-Há" |
| 135 | (aref calendar-bahai-month-name-array (1- m)))) |
| 136 | (day (number-to-string |
| 137 | (if (<= d 0) |
| 138 | (+ d (if (calendar-bahai-leap-year-p y) 5 4)) |
| 139 | d))) |
| 140 | (year (number-to-string y)) |
| 141 | (month (number-to-string m)) |
| 142 | dayname) |
| 143 | ;; Can't call calendar-date-string because of monthname oddity. |
| 144 | (mapconcat 'eval calendar-date-display-form ""))))) |
| 145 | |
| 146 | ;;;###cal-autoload |
| 147 | (defun calendar-bahai-print-date () |
| 148 | "Show the Bahá'í calendar equivalent of the selected date." |
| 149 | (interactive) |
| 150 | (let ((s (calendar-bahai-date-string (calendar-cursor-to-date t)))) |
| 151 | (if (string-equal s "") |
| 152 | (message "Date is pre-Bahá'í") |
| 153 | (message "Bahá'í date: %s" s)))) |
| 154 | |
| 155 | (define-obsolete-function-alias |
| 156 | 'calendar-print-bahai-date 'calendar-bahai-print-date "23.1") |
| 157 | |
| 158 | (defun calendar-bahai-read-date () |
| 159 | "Interactively read the arguments for a Bahá'í date command. |
| 160 | Reads a year, month and day." |
| 161 | (let* ((today (calendar-current-date)) |
| 162 | (year (calendar-read |
| 163 | "Bahá'í calendar year (not 0): " |
| 164 | (lambda (x) (not (zerop x))) |
| 165 | (number-to-string |
| 166 | (calendar-extract-year |
| 167 | (calendar-bahai-from-absolute |
| 168 | (calendar-absolute-from-gregorian today)))))) |
| 169 | (completion-ignore-case t) |
| 170 | (month (cdr (assoc |
| 171 | (completing-read |
| 172 | "Bahá'í calendar month name: " |
| 173 | (mapcar 'list |
| 174 | (append calendar-bahai-month-name-array nil)) |
| 175 | nil t) |
| 176 | (calendar-make-alist calendar-bahai-month-name-array |
| 177 | 1)))) |
| 178 | (day (calendar-read "Bahá'í calendar day (1-19): " |
| 179 | (lambda (x) (and (< 0 x) (<= x 19)))))) |
| 180 | (list (list month day year)))) |
| 181 | |
| 182 | (define-obsolete-function-alias |
| 183 | 'calendar-bahai-prompt-for-date 'calendar-bahai-read-date "23.1") |
| 184 | |
| 185 | ;;;###cal-autoload |
| 186 | (defun calendar-bahai-goto-date (date &optional noecho) |
| 187 | "Move cursor to Bahá'í date DATE; echo Bahá'í date unless NOECHO is non-nil." |
| 188 | (interactive (calendar-bahai-read-date)) |
| 189 | (calendar-goto-date (calendar-gregorian-from-absolute |
| 190 | (calendar-bahai-to-absolute date))) |
| 191 | (or noecho (calendar-bahai-print-date))) |
| 192 | |
| 193 | (define-obsolete-function-alias |
| 194 | 'calendar-goto-bahai-date 'calendar-bahai-goto-date "23.1") |
| 195 | |
| 196 | (defvar displayed-month) |
| 197 | (defvar displayed-year) |
| 198 | |
| 199 | ;;;###holiday-autoload |
| 200 | (defun holiday-bahai (month day string) |
| 201 | "Holiday on MONTH, DAY (Bahá'í) called STRING. |
| 202 | If MONTH, DAY (Bahá'í) is visible in the current calendar window, |
| 203 | returns the corresponding Gregorian date in the form of the |
| 204 | list (((month day year) STRING)). Otherwise, returns nil." |
| 205 | ;; Since the calendar window shows 3 months at a time, there are |
| 206 | ;; approx +/- 45 days either side of the central month. |
| 207 | ;; Since the Bahai months have 19 days, this means up to +/- 3 months. |
| 208 | (let* ((bahai-date (calendar-bahai-from-absolute |
| 209 | (calendar-absolute-from-gregorian |
| 210 | (list displayed-month 15 displayed-year)))) |
| 211 | (m (calendar-extract-month bahai-date)) |
| 212 | (y (calendar-extract-year bahai-date)) |
| 213 | date) |
| 214 | (unless (< m 1) ; Bahá'í calendar doesn't apply |
| 215 | ;; Cf holiday-fixed, holiday-islamic. |
| 216 | ;; With a +- 3 month calendar window, and 19 months per year, |
| 217 | ;; month 16 is special. When m16 is central is when the |
| 218 | ;; end-of-year first appears. When m1 is central, m16 is no |
| 219 | ;; longer visible. Hence we can do a one-sided test to see if |
| 220 | ;; m16 is visible. m16 is visible when the central month >= 13. |
| 221 | ;; To see if other months are visible we can shift the range |
| 222 | ;; accordingly. |
| 223 | (calendar-increment-month m y (- 16 month) 19) |
| 224 | (and (> m 12) ; Bahá'í date might be visible |
| 225 | (calendar-date-is-visible-p |
| 226 | (setq date (calendar-gregorian-from-absolute |
| 227 | (calendar-bahai-to-absolute (list month day y))))) |
| 228 | (list (list date string)))))) |
| 229 | |
| 230 | (autoload 'holiday-fixed "holidays") |
| 231 | |
| 232 | ;;;###holiday-autoload |
| 233 | (defun holiday-bahai-new-year () |
| 234 | "Holiday entry for the Bahá'í New Year, if visible in the calendar window." |
| 235 | (holiday-fixed 3 21 |
| 236 | (format "Bahá'í New Year (Naw-Ruz) %d" |
| 237 | (- displayed-year (1- 1844))))) |
| 238 | |
| 239 | ;;;###holiday-autoload |
| 240 | (defun holiday-bahai-ridvan (&optional all) |
| 241 | "Holidays related to Ridvan, as visible in the calendar window. |
| 242 | Only considers the first, ninth, and twelfth days, unless ALL or |
| 243 | `calendar-bahai-all-holidays-flag' is non-nil." |
| 244 | (let ((ord ["First" "Second" "Third" "Fourth" "Fifth" "Sixth" |
| 245 | "Seventh" "Eighth" "Ninth" "Tenth" "Eleventh" "Twelfth"]) |
| 246 | (show '(0 8 11)) |
| 247 | rid h) |
| 248 | (if (or all calendar-bahai-all-holidays-flag) |
| 249 | (setq show (number-sequence 0 11))) |
| 250 | ;; More trouble than it was worth...? |
| 251 | (dolist (i show (nreverse rid)) |
| 252 | (if (setq h (holiday-fixed (if (< i 10) 4 5) |
| 253 | (+ i (if (< i 10) 21 -9)) |
| 254 | (format "%s Day of Ridvan" (aref ord i)))) |
| 255 | (push (car h) rid))))) |
| 256 | |
| 257 | (autoload 'diary-list-entries-1 "diary-lib") |
| 258 | |
| 259 | ;;;###diary-autoload |
| 260 | (defun diary-bahai-list-entries () |
| 261 | "Add any Bahá'í date entries from the diary file to `diary-entries-list'. |
| 262 | Bahá'í date diary entries must be prefaced by `diary-bahai-entry-symbol' |
| 263 | \(normally a `B'). The same diary date forms govern the style of the |
| 264 | Bahá'í calendar entries, except that the Bahá'í month names cannot be |
| 265 | abbreviated. The Bahá'í months are numbered from 1 to 19 with Bahá being |
| 266 | 1 and 19 being `Alá. If a Bahá'í date diary entry begins with |
| 267 | `diary-nonmarking-symbol', the entry will appear in the diary listing, but |
| 268 | will not be marked in the calendar. This function is provided for use with |
| 269 | `diary-nongregorian-listing-hook'." |
| 270 | (diary-list-entries-1 calendar-bahai-month-name-array |
| 271 | diary-bahai-entry-symbol |
| 272 | 'calendar-bahai-from-absolute)) |
| 273 | (define-obsolete-function-alias |
| 274 | 'list-bahai-diary-entries 'diary-bahai-list-entries "23.1") |
| 275 | |
| 276 | |
| 277 | (autoload 'calendar-mark-1 "diary-lib") |
| 278 | |
| 279 | ;;;###diary-autoload |
| 280 | (defun calendar-bahai-mark-date-pattern (month day year &optional color) |
| 281 | "Mark dates in calendar window that conform to Bahá'í date MONTH/DAY/YEAR. |
| 282 | A value of 0 in any position is a wildcard. Optional argument COLOR is |
| 283 | passed to `calendar-mark-visible-date' as MARK." |
| 284 | (calendar-mark-1 month day year 'calendar-bahai-from-absolute |
| 285 | 'calendar-bahai-to-absolute color)) |
| 286 | |
| 287 | (define-obsolete-function-alias |
| 288 | 'mark-bahai-calendar-date-pattern 'calendar-bahai-mark-date-pattern "23.1") |
| 289 | |
| 290 | |
| 291 | (autoload 'diary-mark-entries-1 "diary-lib") |
| 292 | |
| 293 | ;;;###diary-autoload |
| 294 | (defun diary-bahai-mark-entries () |
| 295 | "Mark days in the calendar window that have Bahá'í date diary entries. |
| 296 | Marks each entry in `diary-file' (or included files) visible in the calendar |
| 297 | window. See `diary-bahai-list-entries' for more information." |
| 298 | (diary-mark-entries-1 'calendar-bahai-mark-date-pattern |
| 299 | calendar-bahai-month-name-array |
| 300 | diary-bahai-entry-symbol |
| 301 | 'calendar-bahai-from-absolute)) |
| 302 | |
| 303 | (define-obsolete-function-alias |
| 304 | 'mark-bahai-diary-entries 'diary-bahai-mark-entries "23.1") |
| 305 | |
| 306 | |
| 307 | (autoload 'diary-insert-entry-1 "diary-lib") |
| 308 | |
| 309 | ;;;###cal-autoload |
| 310 | (defun diary-bahai-insert-entry (arg) |
| 311 | "Insert a diary entry. |
| 312 | For the Bahá'í date corresponding to the date indicated by point. |
| 313 | Prefix argument ARG makes the entry nonmarking." |
| 314 | (interactive "P") |
| 315 | (diary-insert-entry-1 nil arg calendar-bahai-month-name-array |
| 316 | diary-bahai-entry-symbol |
| 317 | 'calendar-bahai-from-absolute)) |
| 318 | |
| 319 | (define-obsolete-function-alias |
| 320 | 'insert-bahai-diary-entry 'diary-bahai-insert-entry "23.1") |
| 321 | |
| 322 | ;;;###cal-autoload |
| 323 | (defun diary-bahai-insert-monthly-entry (arg) |
| 324 | "Insert a monthly diary entry. |
| 325 | For the day of the Bahá'í month corresponding to the date indicated by point. |
| 326 | Prefix argument ARG makes the entry nonmarking." |
| 327 | (interactive "P") |
| 328 | (diary-insert-entry-1 'monthly arg calendar-bahai-month-name-array |
| 329 | diary-bahai-entry-symbol |
| 330 | 'calendar-bahai-from-absolute)) |
| 331 | |
| 332 | (define-obsolete-function-alias |
| 333 | 'insert-monthly-bahai-diary-entry 'diary-bahai-insert-monthly-entry "23.1") |
| 334 | |
| 335 | ;;;###cal-autoload |
| 336 | (defun diary-bahai-insert-yearly-entry (arg) |
| 337 | "Insert an annual diary entry. |
| 338 | For the day of the Bahá'í year corresponding to the date indicated by point. |
| 339 | Prefix argument ARG will make the entry nonmarking." |
| 340 | (interactive "P") |
| 341 | (diary-insert-entry-1 'yearly arg calendar-bahai-month-name-array |
| 342 | diary-bahai-entry-symbol |
| 343 | 'calendar-bahai-from-absolute)) |
| 344 | |
| 345 | (define-obsolete-function-alias |
| 346 | 'insert-yearly-bahai-diary-entry 'diary-bahai-insert-yearly-entry "23.1") |
| 347 | |
| 348 | (defvar date) |
| 349 | |
| 350 | ;; To be called from diary-list-sexp-entries, where DATE is bound. |
| 351 | ;;;###diary-autoload |
| 352 | (defun diary-bahai-date () |
| 353 | "Bahá'í calendar equivalent of date diary entry." |
| 354 | (format "Bahá'í date: %s" (calendar-bahai-date-string date))) |
| 355 | |
| 356 | |
| 357 | (provide 'cal-bahai) |
| 358 | |
| 359 | ;; Local Variables: |
| 360 | ;; coding: utf-8 |
| 361 | ;; End: |
| 362 | |
| 363 | ;;; cal-bahai.el ends here |