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

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