lisp/calendar/cal-bahai.el

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