code.delx.au - gnu-emacs/blob - lisp/calendar/cal-bahai.el

   1 ;;; cal-bahai.el --- calendar functions for the Bahá'í calendar.
   2
   3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: John Wiegley <johnw@gnu.org>
   7 ;; Keywords: calendar
   8 ;; Human-Keywords: Bahá'í calendar, Bahá'í, 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
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  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
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This collection of functions implements the features of calendar.el
  30 ;; and diary.el that deal with the Bahá'í calendar.
  31
  32 ;; The Bahá'í (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 Ayyám-i-Há (days of Há), 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 (Há
  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 ;; Váhids.  A cycle of 19 Váhids (361 years) is called a Kullu-Shay,
  45 ;; which means "all things".
  46
  47 ;; The calendar was named the "Badí` calendar" by its author, the Báb.
  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 Ayyám-i-Há 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 Ayyám-i-Há, in the year 157 BE.
  55
  56 ;;; Code:
  57
  58 (require 'calendar)
  59
  60 (defconst calendar-bahai-month-name-array
  61   ["Bahá" "Jalál" "Jamál" "`Azamat" "Núr" "Rahmat" "Kalimát" "Kamál"
  62    "Asmá" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masá'il"
  63    "Sharaf" "Sultán" "Mulk" "`Alá"]
  64   "Array of the month names in the Bahá'í calendar.")
  65
  66 (defconst calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844))
  67   "Absolute date of start of Bahá'í calendar = March 21, 1844 AD.")
  68
  69 (defun calendar-bahai-leap-year-p (year)
  70   "True if Bahá'í YEAR is a leap year in the Bahá'í calendar."
  71   (calendar-leap-year-p (+ year 1844)))
  72
  73 (defconst calendar-bahai-leap-base
  74   (+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400))
  75   "Number of leap years between 1 and 1844 AD, inclusive.
  76 Used by `calendar-absolute-from-bahai'.")
  77
  78 (defun calendar-absolute-from-bahai (date)
  79   "Compute absolute date from Bahá'í date DATE.
  80 The absolute date is the number of days elapsed since the (imaginary)
  81 Gregorian date Sunday, December 31, 1 BC."
  82   (let* ((month (extract-calendar-month date))
  83          (day (extract-calendar-day date))
  84          (year (extract-calendar-year date))
  85          (prior-years (+ (1- year) 1844))
  86          (leap-days (- (+ (/ prior-years 4) ; leap days in prior years
  87                           (- (/ prior-years 100))
  88                           (/ prior-years 400))
  89                        calendar-bahai-leap-base)))
  90     (+ (1- calendar-bahai-epoch)        ; days before epoch
  91        (* 365 (1- year))                ; days in prior years
  92        leap-days
  93        (calendar-sum m 1 (< m month) 19)
  94        (if (= month 19)
  95            (if (calendar-bahai-leap-year-p year) 5 4)
  96          0)
  97        day)))                           ; days so far this month
  98
  99 (defun calendar-bahai-from-absolute (date)
 100   "Bahá'í date (month day year) corresponding to the absolute DATE."
 101   (if (< date calendar-bahai-epoch)
 102       (list 0 0 0)                      ; pre-Bahá'í date
 103     (let* ((greg (calendar-gregorian-from-absolute date))
 104            (gmonth (extract-calendar-month greg))
 105            (year (+ (- (extract-calendar-year greg) 1844)
 106                     (if (or (> gmonth 3)
 107                             (and (= gmonth 3)
 108                                  (>= (extract-calendar-day greg) 21)))
 109                         1 0)))
 110            (month                       ; search forward from Baha
 111             (1+ (calendar-sum m 1
 112                   (> date (calendar-absolute-from-bahai (list m 19 year)))
 113                   1)))
 114            (day                     ; calculate the day by subtraction
 115             (- date
 116                (1- (calendar-absolute-from-bahai (list month 1 year))))))
 117       (list month day year))))
 118
 119 ;;;###cal-autoload
 120 (defun calendar-bahai-date-string (&optional date)
 121   "String of Bahá'í date of Gregorian DATE.
 122 Defaults to today's date if DATE is not given."
 123   (let* ((bahai-date (calendar-bahai-from-absolute
 124                       (calendar-absolute-from-gregorian
 125                        (or date (calendar-current-date)))))
 126          (y (extract-calendar-year bahai-date)))
 127     (if (< y 1)
 128         ""                              ; pre-Bahai
 129       (let* ((m (extract-calendar-month bahai-date))
 130              (d (extract-calendar-day bahai-date))
 131              (monthname (if (and (= m 19)
 132                                  (<= d 0))
 133                             "Ayyám-i-Há"
 134                           (aref calendar-bahai-month-name-array (1- m))))
 135              (day (int-to-string
 136                    (if (<= d 0)
 137                        (+ d (if (calendar-bahai-leap-year-p y) 5 4))
 138                      d)))
 139              (year (int-to-string y))
 140              (month (int-to-string m))
 141              dayname)
 142         ;; Can't call calendar-date-string because of monthname oddity.
 143         (mapconcat 'eval calendar-date-display-form "")))))
 144
 145 ;;;###cal-autoload
 146 (defun calendar-bahai-print-date ()
 147   "Show the Bahá'í calendar equivalent of the selected date."
 148   (interactive)
 149   (let ((s (calendar-bahai-date-string (calendar-cursor-to-date t))))
 150    (if (string-equal s "")
 151        (message "Date is pre-Bahá'í")
 152      (message "Bahá'í date: %s" s))))
 153
 154 (define-obsolete-function-alias
 155   'calendar-print-bahai-date 'calendar-bahai-print-date "23.1")
 156
 157 (defun calendar-bahai-read-date ()
 158  "Interactively read the arguments for a Bahá'í date command.
 159 Reads a year, month and day."
 160   (let* ((today (calendar-current-date))
 161          (year (calendar-read
 162                 "Bahá'í calendar year (not 0): "
 163                 (lambda (x) (not (zerop x)))
 164                 (int-to-string
 165                  (extract-calendar-year
 166                   (calendar-bahai-from-absolute
 167                    (calendar-absolute-from-gregorian today))))))
 168          (completion-ignore-case t)
 169          (month (cdr (assoc
 170                       (completing-read
 171                        "Bahá'í calendar month name: "
 172                        (mapcar 'list
 173                                (append calendar-bahai-month-name-array nil))
 174                        nil t)
 175                       (calendar-make-alist calendar-bahai-month-name-array
 176                                            1))))
 177          (day (calendar-read "Bahá'í calendar day (1-19): "
 178                              (lambda (x) (and (< 0 x) (<= x 19))))))
 179     (list (list month day year))))
 180
 181 (define-obsolete-function-alias
 182   'calendar-bahai-prompt-for-date 'calendar-bahai-read-date "23.1")
 183
 184 ;;;###cal-autoload
 185 (defun calendar-bahai-goto-date (date &optional noecho)
 186   "Move cursor to Bahá'í date DATE; echo Bahá'í date unless NOECHO is non-nil."
 187   (interactive (calendar-bahai-read-date))
 188   (calendar-goto-date (calendar-gregorian-from-absolute
 189                        (calendar-absolute-from-bahai date)))
 190   (or noecho (calendar-bahai-print-date)))
 191
 192 (define-obsolete-function-alias
 193   'calendar-goto-bahai-date 'calendar-bahai-goto-date "23.1")
 194
 195 (defvar displayed-month)
 196 (defvar displayed-year)
 197
 198 ;;;###holiday-autoload
 199 (defun holiday-bahai (month day string)
 200   "Holiday on MONTH, DAY (Bahá'í) called STRING.
 201 If MONTH, DAY (Bahá'í) is visible, the value returned is corresponding
 202 Gregorian date in the form of the list (((month day year) STRING)).  Returns
 203 nil if it is not visible in the current calendar window."
 204   ;; Since the calendar window shows 3 months at a time, there are
 205   ;; approx +/- 45 days either side of the central month.
 206   ;; Since the Bahai months have 19 days, this means up to +/- 3 months.
 207   (let* ((bahai-date (calendar-bahai-from-absolute
 208                       (calendar-absolute-from-gregorian
 209                        (list displayed-month 15 displayed-year))))
 210          (m (extract-calendar-month bahai-date))
 211          (y (extract-calendar-year bahai-date))
 212          date)
 213     (unless (< m 1)                    ; Bahá'í calendar doesn't apply
 214       ;; Cf holiday-fixed, holiday-islamic.
 215       ;; With a +- 3 month calendar window, and 19 months per year,
 216       ;; month 16 is special.  When m16 is central is when the
 217       ;; end-of-year first appears.  When m1 is central, m16 is no
 218       ;; longer visible.  Hence we can do a one-sided test to see if
 219       ;; m16 is visible.  m16 is visible when the central month >= 13.
 220       ;; To see if other months are visible we can shift the range
 221       ;; accordingly.
 222       (increment-calendar-month m y (- 16 month) 19)
 223       (and (> m 12)                     ; Bahá'í date might be visible
 224            (calendar-date-is-visible-p
 225             (setq date (calendar-gregorian-from-absolute
 226                         (calendar-absolute-from-bahai (list month day y)))))
 227            (list (list date string))))))
 228
 229 (autoload 'diary-list-entries-1 "diary-lib")
 230
 231 ;;;###diary-autoload
 232 (defun diary-bahai-list-entries ()
 233   "Add any Bahá'í date entries from the diary file to `diary-entries-list'.
 234 Bahá'í date diary entries must be prefaced by `bahai-diary-entry-symbol'
 235 \(normally a `B').  The same diary date forms govern the style of the
 236 Bahá'í calendar entries, except that the Bahá'í month names cannot be
 237 abbreviated.  The Bahá'í months are numbered from 1 to 19 with Bahá being
 238 1 and 19 being `Alá.  If a Bahá'í date diary entry begins with
 239 `diary-nonmarking-symbol', the entry will appear in the diary listing, but
 240 will not be marked in the calendar.  This function is provided for use with
 241 `nongregorian-diary-listing-hook'."
 242   (diary-list-entries-1 calendar-bahai-month-name-array
 243                         bahai-diary-entry-symbol
 244                         'calendar-bahai-from-absolute))
 245 (define-obsolete-function-alias
 246   'list-bahai-diary-entries 'diary-bahai-list-entries "23.1")
 247
 248
 249 (autoload 'calendar-mark-1 "diary-lib")
 250
 251 ;;;###diary-autoload
 252 (defun calendar-bahai-mark-date-pattern (month day year &optional color)
 253   "Mark dates in calendar window that conform to Bahá'í date MONTH/DAY/YEAR.
 254 A value of 0 in any position is a wildcard.  Optional argument COLOR is
 255 passed to `mark-visible-calendar-date' as MARK."
 256   (calendar-mark-1 month day year 'calendar-bahai-from-absolute
 257                    'calendar-absolute-from-bahai color))
 258
 259 (define-obsolete-function-alias
 260   'mark-bahai-calendar-date-pattern 'calendar-bahai-mark-date-pattern "23.1")
 261
 262
 263 (autoload 'diary-mark-entries-1 "diary-lib")
 264
 265 ;;;###diary-autoload
 266 (defun diary-bahai-mark-entries ()
 267   "Mark days in the calendar window that have Bahá'í date diary entries.
 268 Marks each entry in `diary-file' (or included files) visible in the calendar
 269 window.  See `diary-bahai-list-entries' for more information."
 270   (diary-mark-entries-1 'calendar-bahai-mark-date-pattern
 271                         calendar-bahai-month-name-array
 272                         bahai-diary-entry-symbol
 273                         'calendar-bahai-from-absolute))
 274
 275 (define-obsolete-function-alias
 276   'mark-bahai-diary-entries 'diary-bahai-mark-entries "23.1")
 277
 278
 279 (autoload 'diary-insert-entry-1 "diary-lib")
 280
 281 ;;;###cal-autoload
 282 (defun diary-bahai-insert-entry (arg)
 283   "Insert a diary entry.
 284 For the Bahá'í date corresponding to the date indicated by point.
 285 Prefix argument ARG makes the entry nonmarking."
 286   (interactive "P")
 287   (diary-insert-entry-1 nil arg calendar-bahai-month-name-array
 288                         bahai-diary-entry-symbol
 289                         'calendar-bahai-from-absolute))
 290
 291 (define-obsolete-function-alias
 292   'insert-bahai-diary-entry 'diary-bahai-insert-entry "23.1")
 293
 294 ;;;###cal-autoload
 295 (defun diary-bahai-insert-monthly-entry (arg)
 296   "Insert a monthly diary entry.
 297 For the day of the Bahá'í month corresponding to the date indicated by point.
 298 Prefix argument ARG makes the entry nonmarking."
 299   (interactive "P")
 300   (diary-insert-entry-1 'monthly arg calendar-bahai-month-name-array
 301                         bahai-diary-entry-symbol
 302                         'calendar-bahai-from-absolute))
 303
 304 (define-obsolete-function-alias
 305   'insert-monthly-bahai-diary-entry 'diary-bahai-insert-monthly-entry "23.1")
 306
 307 ;;;###cal-autoload
 308 (defun diary-bahai-insert-yearly-entry (arg)
 309   "Insert an annual diary entry.
 310 For the day of the Bahá'í year corresponding to the date indicated by point.
 311 Prefix argument ARG will make the entry nonmarking."
 312   (interactive "P")
 313   (diary-insert-entry-1 'yearly arg calendar-bahai-month-name-array
 314                         bahai-diary-entry-symbol
 315                         'calendar-bahai-from-absolute))
 316
 317 (define-obsolete-function-alias
 318   'insert-yearly-bahai-diary-entry 'diary-bahai-insert-yearly-entry "23.1")
 319
 320 (defvar date)
 321
 322 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 323 ;;;###diary-autoload
 324 (defun diary-bahai-date ()
 325   "Bahá'í calendar equivalent of date diary entry."
 326   (format "Bahá'í date: %s" (calendar-bahai-date-string date)))
 327
 328
 329 (provide 'cal-bahai)
 330
 331 ;; Local Variables:
 332 ;; coding: utf-8
 333 ;; End:
 334
 335 ;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
 336 ;;; cal-bahai.el ends here