code.delx.au - gnu-emacs/blob - 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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, 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 (require 'cal-julian)
  58
  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"])
  63
  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).")
  66
  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)))
  70
  71 (defvar bahai-calendar-leap-base
  72   (+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400)))
  73
  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))
  84                           (/ prior-years 400))
  85                        bahai-calendar-leap-base)))
  86     (+ (1- calendar-bahai-epoch)        ; Days before epoch
  87        (* 365 (1- year))                ; Days in prior years.
  88        leap-days
  89        (calendar-sum m 1 (< m month) 19)
  90        (if (= month 19) 4 0)
  91        day)))                           ; Days so far this month.
  92
  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)))
 102                         1 0)))
 103            (month ;; Search forward from Baha.
 104             (1+ (calendar-sum m 1
 105                               (> date
 106                                  (calendar-absolute-from-bahai
 107                                   (list m 19 year)))
 108                               1)))
 109            (day ;; Calculate the day by subtraction.
 110             (- date
 111                (1- (calendar-absolute-from-bahai (list month 1 year))))))
 112       (list month day year))))
 113
 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)))
 123     (let ((monthname
 124            (if (and (= m 19)
 125                     (<= d 0))
 126                "Ayyam-i-Ha"
 127              (aref bahai-calendar-month-name-array (1- m))))
 128           (day (int-to-string
 129                 (if (<= d 0)
 130                     (if (bahai-calendar-leap-year-p y)
 131                         (+ d 5)
 132                       (+ d 4))
 133                   d)))
 134           (dayname nil)
 135           (month (int-to-string m))
 136           (year (int-to-string y)))
 137       (mapconcat 'eval calendar-date-display-form ""))))
 138
 139 (defun calendar-print-bahai-date ()
 140   "Show the Baha'i calendar equivalent of the selected date."
 141   (interactive)
 142   (message "Baha'i date: %s"
 143            (calendar-bahai-date-string (calendar-cursor-to-date t))))
 144
 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)))
 152
 153 (defun bahai-prompt-for-date ()
 154   "Ask for a Baha'i date."
 155   (let* ((today (calendar-current-date))
 156          (year (calendar-read
 157                 "Baha'i calendar year (not 0): "
 158                 '(lambda (x) (/= x 0))
 159                 (int-to-string
 160                  (extract-calendar-year
 161                   (calendar-bahai-from-absolute
 162                    (calendar-absolute-from-gregorian today))))))
 163          (completion-ignore-case t)
 164          (month (cdr (assoc
 165                        (completing-read
 166                         "Baha'i calendar month name: "
 167                         (mapcar 'list
 168                                 (append bahai-calendar-month-name-array nil))
 169                         nil t)
 170                       (calendar-make-alist bahai-calendar-month-name-array
 171                                            1))))
 172          (day (calendar-read "Baha'i calendar day (1-19): "
 173                              '(lambda (x) (and (< 0 x) (<= x 19))))))
 174     (list (list month day year))))
 175
 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)))
 179
 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))
 190          (date))
 191     (if (< m 1)
 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))))))))
 199
 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'."
 211   (if (< 0 number)
 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)))
 223              (while d
 224                (let*
 225                    ((date-form (if (equal (car (car d)) 'backup)
 226                                    (cdr (car d))
 227                                  (car d)))
 228                     (backup (equal (car (car d)) 'backup))
 229                     (dayname
 230                      (concat
 231                       (calendar-day-name gdate) "\\|"
 232                       (substring (calendar-day-name gdate) 0 3) ".?"))
 233                     (calendar-month-name-array
 234                      bahai-calendar-month-name-array)
 235                     (monthname
 236                      (concat
 237                       "\\*\\|"
 238                       (calendar-month-name month)))
 239                     (month (concat "\\*\\|0*" (int-to-string month)))
 240                     (day (concat "\\*\\|0*" (int-to-string day)))
 241                     (year
 242                      (concat
 243                       "\\*\\|0*" (int-to-string year)
 244                       (if abbreviated-calendar-year
 245                           (concat "\\|" (int-to-string (% year 100)))
 246                         "")))
 247                     (regexp
 248                      (concat
 249                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
 250                       (regexp-quote bahai-diary-entry-symbol)
 251                       "\\("
 252                       (mapconcat 'eval date-form "\\)\\(")
 253                       "\\)"))
 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.
 262                        (backward-char 1)
 263                      ;;  Found a nonempty diary entry--make it visible and
 264                      ;;  add it to the list.
 265                      (let ((entry-start (point))
 266                            (date-start))
 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))
 272                        (backward-char 1)
 273                        (subst-char-in-region date-start (point) ?\^M ?\n t)
 274                        (add-to-diary-list
 275                         gdate
 276                         (buffer-substring-no-properties entry-start (point))
 277                         (buffer-substring-no-properties
 278                          (1+ date-start) (1- entry-start)))))))
 279                (setq d (cdr d))))
 280            (setq gdate
 281                  (calendar-gregorian-from-absolute
 282                   (1+ (calendar-absolute-from-gregorian gdate)))))
 283            (set-buffer-modified-p diary-modified))
 284         (goto-char (point-min))))
 285
 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))
 299     (while d
 300       (let*
 301           ((date-form (if (equal (car (car d)) 'backup)
 302                           (cdr (car d))
 303                         (car d)));; ignore 'backup directive
 304            (dayname (diary-name-pattern calendar-day-name-array))
 305            (monthname
 306             (concat
 307              (diary-name-pattern bahai-calendar-month-name-array t)
 308              "\\|\\*"))
 309            (month "[0-9]+\\|\\*")
 310            (day "[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)))
 323            (regexp
 324             (concat
 325              "\\(\\`\\|\^M\\|\n\\)"
 326              (regexp-quote bahai-diary-entry-symbol)
 327              "\\("
 328              (mapconcat 'eval date-form "\\)\\(")
 329              "\\)"))
 330            (case-fold-search t))
 331         (goto-char (point-min))
 332         (while (re-search-forward regexp nil t)
 333           (let* ((dd-name
 334                   (if d-name-pos
 335                       (buffer-substring
 336                        (match-beginning d-name-pos)
 337                        (match-end d-name-pos))))
 338                  (mm-name
 339                   (if m-name-pos
 340                       (buffer-substring
 341                        (match-beginning m-name-pos)
 342                        (match-end m-name-pos))))
 343                  (mm (string-to-int
 344                       (if m-pos
 345                           (buffer-substring
 346                            (match-beginning m-pos)
 347                            (match-end m-pos))
 348                         "")))
 349                  (dd (string-to-int
 350                       (if d-pos
 351                           (buffer-substring
 352                            (match-beginning d-pos)
 353                            (match-end d-pos))
 354                         "")))
 355                  (y-str (if y-pos
 356                             (buffer-substring
 357                              (match-beginning y-pos)
 358                              (match-end y-pos))))
 359                  (yy (if (not y-str)
 360                          0
 361                        (if (and (= (length y-str) 2)
 362                                 abbreviated-calendar-year)
 363                            (let* ((current-y
 364                                    (extract-calendar-year
 365                                     (calendar-bahai-from-absolute
 366                                      (calendar-absolute-from-gregorian
 367                                       (calendar-current-date)))))
 368                                   (y (+ (string-to-int y-str)
 369                                         (* 100 (/ current-y 100)))))
 370                              (if (> (- y current-y) 50)
 371                                  (- y 100)
 372                                (if (> (- current-y y) 50)
 373                                    (+ y 100)
 374                                  y)))
 375                          (string-to-int y-str)))))
 376             (if dd-name
 377                 (mark-calendar-days-named
 378                  (cdr (assoc-ignore-case (substring dd-name 0 3)
 379                                          (calendar-make-alist
 380                                           calendar-day-name-array
 381                                           0
 382                                           '(lambda (x) (substring x 0 3))))))
 383               (if mm-name
 384                   (if (string-equal mm-name "*")
 385                       (setq mm 0)
 386                     (setq mm
 387                           (cdr (assoc-ignore-case
 388                                 mm-name
 389                                 (calendar-make-alist
 390                                   bahai-calendar-month-name-array))))))
 391               (mark-bahai-calendar-date-pattern mm dd yy)))))
 392       (setq d (cdr d)))))
 393
 394 (defun mark-bahai-calendar-date-pattern (month day year)
 395   "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.
 396 A value of 0 in any position is a wildcard."
 397   (save-excursion
 398     (set-buffer calendar-buffer)
 399     (if (and (/= 0 month) (/= 0 day))
 400         (if (/= 0 year)
 401             ;; Fully specified Baha'i date.
 402             (let ((date (calendar-gregorian-from-absolute
 403                          (calendar-absolute-from-bahai
 404                           (list month day year)))))
 405               (if (calendar-date-is-visible-p date)
 406                   (mark-visible-calendar-date date)))
 407           ;; Month and day in any year--this taken from the holiday stuff.
 408           (let* ((bahai-date (calendar-bahai-from-absolute
 409                                 (calendar-absolute-from-gregorian
 410                                  (list displayed-month 15 displayed-year))))
 411                  (m (extract-calendar-month bahai-date))
 412                  (y (extract-calendar-year bahai-date))
 413                  (date))
 414             (if (< m 1)
 415                 nil;;   Baha'i calendar doesn't apply.
 416               (increment-calendar-month m y (- 10 month))
 417               (if (> m 7);;  Baha'i date might be visible
 418                   (let ((date (calendar-gregorian-from-absolute
 419                                (calendar-absolute-from-bahai
 420                                 (list month day y)))))
 421                     (if (calendar-date-is-visible-p date)
 422                         (mark-visible-calendar-date date)))))))
 423       ;; Not one of the simple cases--check all visible dates for match.
 424       ;; Actually, the following code takes care of ALL of the cases, but
 425       ;; it's much too slow to be used for the simple (common) cases.
 426       (let ((m displayed-month)
 427             (y displayed-year)
 428             (first-date)
 429             (last-date))
 430         (increment-calendar-month m y -1)
 431         (setq first-date
 432               (calendar-absolute-from-gregorian
 433                (list m 1 y)))
 434         (increment-calendar-month m y 2)
 435         (setq last-date
 436               (calendar-absolute-from-gregorian
 437                (list m (calendar-last-day-of-month m y) y)))
 438         (calendar-for-loop date from first-date to last-date do
 439           (let* ((b-date (calendar-bahai-from-absolute date))
 440                  (i-month (extract-calendar-month b-date))
 441                  (i-day (extract-calendar-day b-date))
 442                  (i-year (extract-calendar-year b-date)))
 443             (and (or (zerop month)
 444                      (= month i-month))
 445                  (or (zerop day)
 446                      (= day i-day))
 447                  (or (zerop year)
 448                      (= year i-year))
 449                  (mark-visible-calendar-date
 450                   (calendar-gregorian-from-absolute date)))))))))
 451
 452 (defun insert-bahai-diary-entry (arg)
 453   "Insert a diary entry.
 454 For the Baha'i date corresponding to the date indicated by point.
 455 Prefix arg will make the entry nonmarking."
 456   (interactive "P")
 457   (let* ((calendar-month-name-array bahai-calendar-month-name-array))
 458     (make-diary-entry
 459      (concat
 460       bahai-diary-entry-symbol
 461       (calendar-date-string
 462        (calendar-bahai-from-absolute
 463         (calendar-absolute-from-gregorian
 464          (calendar-cursor-to-date t)))
 465        nil t))
 466      arg)))
 467
 468 (defun insert-monthly-bahai-diary-entry (arg)
 469   "Insert a monthly diary entry.
 470 For the day of the Baha'i month corresponding to the date indicated by point.
 471 Prefix arg will make the entry nonmarking."
 472   (interactive "P")
 473   (let* ((calendar-date-display-form
 474           (if european-calendar-style '(day " * ") '("* " day )))
 475          (calendar-month-name-array bahai-calendar-month-name-array))
 476     (make-diary-entry
 477      (concat
 478       bahai-diary-entry-symbol
 479       (calendar-date-string
 480        (calendar-bahai-from-absolute
 481         (calendar-absolute-from-gregorian
 482          (calendar-cursor-to-date t)))))
 483      arg)))
 484
 485 (defun insert-yearly-bahai-diary-entry (arg)
 486   "Insert an annual diary entry.
 487 For the day of the Baha'i year corresponding to the date indicated by point.
 488 Prefix arg will make the entry nonmarking."
 489   (interactive "P")
 490   (let* ((calendar-date-display-form
 491           (if european-calendar-style
 492               '(day " " monthname)
 493             '(monthname " " day)))
 494          (calendar-month-name-array bahai-calendar-month-name-array))
 495     (make-diary-entry
 496      (concat
 497       bahai-diary-entry-symbol
 498       (calendar-date-string
 499        (calendar-bahai-from-absolute
 500         (calendar-absolute-from-gregorian
 501          (calendar-cursor-to-date t)))))
 502      arg)))
 503
 504 (provide 'cal-bahai)
 505
 506 ;;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
 507 ;;; cal-bahai.el ends here