lisp/calendar/cal-islam.el

   1 ;;; cal-islam.el --- calendar functions for the Islamic calendar
   2
   3 ;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008  Free Software Foundation, Inc.
   5
   6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   8 ;; Keywords: calendar
   9 ;; Human-Keywords: Islamic calendar, calendar, diary
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This collection of functions implements the features of calendar.el and
  31 ;; diary.el that deal with the Islamic calendar.
  32
  33 ;; Technical details of all the calendrical calculations can be found in
  34 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
  35 ;; and Nachum Dershowitz, Cambridge University Press (2001).
  36
  37 ;;; Code:
  38
  39 (defvar displayed-month)
  40 (defvar displayed-year)
  41 (defvar original-date)
  42
  43 (require 'cal-julian)
  44
  45 (defvar calendar-islamic-month-name-array
  46   ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II"
  47    "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"]
  48 "Array of strings giving the names of the Islamic months.")
  49
  50 (defvar calendar-islamic-epoch (calendar-absolute-from-julian '(7 16 622))
  51   "Absolute date of start of Islamic calendar = August 29, 284 A.D. (Julian).")
  52
  53 (defun islamic-calendar-leap-year-p (year)
  54   "Return t if YEAR is a leap year on the Islamic calendar."
  55   (memq (% year 30)
  56         (list 2 5 7 10 13 16 18 21 24 26 29)))
  57
  58 (defun islamic-calendar-last-day-of-month (month year)
  59   "The last day in MONTH during YEAR on the Islamic calendar."
  60   (cond
  61    ((memq month (list 1 3 5 7 9 11)) 30)
  62    ((memq month (list 2 4 6 8 10)) 29)
  63    (t (if (islamic-calendar-leap-year-p year) 30 29))))
  64
  65 (defun islamic-calendar-day-number (date)
  66   "Return the day number within the year of the Islamic date DATE."
  67     (let* ((month (extract-calendar-month date))
  68            (day (extract-calendar-day date)))
  69       (+ (* 30 (/ month 2))
  70          (* 29 (/ (1- month) 2))
  71          day)))
  72
  73 (defun calendar-absolute-from-islamic (date)
  74   "Absolute date of Islamic DATE.
  75 The absolute date is the number of days elapsed since the (imaginary)
  76 Gregorian date Sunday, December 31, 1 BC."
  77   (let* ((month (extract-calendar-month date))
  78          (day (extract-calendar-day date))
  79          (year (extract-calendar-year date))
  80          (y (% year 30))
  81          (leap-years-in-cycle
  82           (cond
  83            ((< y 3) 0)  ((< y 6) 1)  ((< y 8) 2)  ((< y 11) 3) ((< y 14) 4)
  84            ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9)
  85            (t 10))))
  86     (+ (islamic-calendar-day-number date) ; days so far this year
  87        (* (1- year) 354)                  ; days in all non-leap years
  88        (* 11 (/ year 30))             ; leap days in complete cycles
  89        leap-years-in-cycle            ; leap days this cycle
  90        (1- calendar-islamic-epoch)))) ; days before start of calendar
  91
  92 (defun calendar-islamic-from-absolute (date)
  93   "Compute the Islamic date (month day year) corresponding to absolute DATE.
  94 The absolute date is the number of days elapsed since the (imaginary)
  95 Gregorian date Sunday, December 31, 1 BC."
  96   (if (< date calendar-islamic-epoch)
  97       (list 0 0 0)                      ; pre-Islamic date
  98     (let* ((approx (/ (- date calendar-islamic-epoch)
  99                       355))  ; approximation from below
 100            (year             ; search forward from the approximation
 101             (+ approx
 102                (calendar-sum y approx
 103                              (>= date (calendar-absolute-from-islamic
 104                                        (list 1 1 (1+ y))))
 105                              1)))
 106            (month                       ; search forward from Muharram
 107             (1+ (calendar-sum m 1
 108                               (> date
 109                                  (calendar-absolute-from-islamic
 110                                   (list m
 111                                         (islamic-calendar-last-day-of-month
 112                                          m year)
 113                                         year)))
 114                               1)))
 115            (day                    ; calculate the day by subtraction
 116             (- date
 117                (1- (calendar-absolute-from-islamic (list month 1 year))))))
 118       (list month day year))))
 119
 120 ;;;###autoload
 121 (defun calendar-islamic-date-string (&optional date)
 122   "String of Islamic date before sunset of Gregorian DATE.
 123 Returns the empty string if DATE is pre-Islamic.
 124 Defaults to today's date if DATE is not given.
 125 Driven by the variable `calendar-date-display-form'."
 126   (let ((calendar-month-name-array calendar-islamic-month-name-array)
 127         (islamic-date (calendar-islamic-from-absolute
 128                        (calendar-absolute-from-gregorian
 129                         (or date (calendar-current-date))))))
 130     (if (< (extract-calendar-year islamic-date) 1)
 131         ""
 132       (calendar-date-string islamic-date nil t))))
 133
 134 ;;;###autoload
 135 (defun calendar-print-islamic-date ()
 136   "Show the Islamic calendar equivalent of the date under the cursor."
 137   (interactive)
 138   (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
 139     (if (string-equal i "")
 140         (message "Date is pre-Islamic")
 141       (message "Islamic date (until sunset): %s" i))))
 142
 143 ;;;###autoload
 144 (defun calendar-goto-islamic-date (date &optional noecho)
 145   "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t."
 146   (interactive
 147    (let* ((today (calendar-current-date))
 148           (year (calendar-read
 149                  "Islamic calendar year (>0): "
 150                  (lambda (x) (> x 0))
 151                  (int-to-string
 152                   (extract-calendar-year
 153                    (calendar-islamic-from-absolute
 154                     (calendar-absolute-from-gregorian today))))))
 155           (month-array calendar-islamic-month-name-array)
 156           (completion-ignore-case t)
 157           (month (cdr (assoc-string
 158                         (completing-read
 159                          "Islamic calendar month name: "
 160                          (mapcar 'list (append month-array nil))
 161                          nil t)
 162                        (calendar-make-alist month-array 1) t)))
 163           (last (islamic-calendar-last-day-of-month month year))
 164           (day (calendar-read
 165                 (format "Islamic calendar day (1-%d): " last)
 166                 (lambda (x) (and (< 0 x) (<= x last))))))
 167      (list (list month day year))))
 168   (calendar-goto-date (calendar-gregorian-from-absolute
 169                        (calendar-absolute-from-islamic date)))
 170   (or noecho (calendar-print-islamic-date)))
 171
 172 (defun holiday-islamic (month day string)
 173   "Holiday on MONTH, DAY (Islamic) called STRING.
 174 If MONTH, DAY (Islamic) is visible, the value returned is corresponding
 175 Gregorian date in the form of the list (((month day year) STRING)).  Returns
 176 nil if it is not visible in the current calendar window."
 177   (let* ((islamic-date (calendar-islamic-from-absolute
 178                         (calendar-absolute-from-gregorian
 179                          (list displayed-month 15 displayed-year))))
 180          (m (extract-calendar-month islamic-date))
 181          (y (extract-calendar-year islamic-date))
 182         (date))
 183     (if (< m 1)
 184         nil                        ;   Islamic calendar doesn't apply
 185       (increment-calendar-month m y (- 10 month))
 186       (if (> m 7)                     ;  Islamic date might be visible
 187           (let ((date (calendar-gregorian-from-absolute
 188                        (calendar-absolute-from-islamic (list month day y)))))
 189             (if (calendar-date-is-visible-p date)
 190                 (list (list date string))))))))
 191
 192 ;; l-i-d-e should be called from diary code.
 193 (declare-function add-to-diary-list "diary-lib"
 194                   (date string specifier &optional marker globcolor literal))
 195
 196 (defvar number)                         ; from diary-list-entries
 197
 198 (defun list-islamic-diary-entries ()
 199   "Add any Islamic date entries from the diary file to `diary-entries-list'.
 200 Islamic date diary entries must be prefaced by `islamic-diary-entry-symbol'
 201 \(normally an `I').  The same diary date forms govern the style
 202 of the Islamic calendar entries, except that the Islamic month
 203 names must be spelled in full.  The Islamic months are numbered
 204 from 1 to 12 with Muharram being 1 and 12 being Dhu al-Hijjah.
 205 If an Islamic date diary entry begins with `diary-nonmarking-symbol',
 206 the entry will appear in the diary listing, but will not be
 207 marked in the calendar.  This function is provided for use with
 208 `nongregorian-diary-listing-hook'."
 209   (if (< 0 number)
 210       (let ((buffer-read-only nil)
 211             (diary-modified (buffer-modified-p))
 212             (gdate original-date)
 213             (mark (regexp-quote diary-nonmarking-symbol)))
 214         (dotimes (idummy number)
 215           (let* ((d diary-date-forms)
 216                  (idate (calendar-islamic-from-absolute
 217                          (calendar-absolute-from-gregorian gdate)))
 218                  (month (extract-calendar-month idate))
 219                  (day (extract-calendar-day idate))
 220                  (year (extract-calendar-year idate)))
 221             (while d
 222               (let*
 223                   ((date-form (if (equal (car (car d)) 'backup)
 224                                   (cdr (car d))
 225                                 (car d)))
 226                    (backup (equal (car (car d)) 'backup))
 227                    (dayname
 228                     (format "%s\\|%s\\.?"
 229                             (calendar-day-name gdate)
 230                             (calendar-day-name gdate 'abbrev)))
 231                    (calendar-month-name-array
 232                     calendar-islamic-month-name-array)
 233                    (monthname
 234                     (concat
 235                      "\\*\\|"
 236                      (calendar-month-name month)))
 237                    (month (concat "\\*\\|0*" (int-to-string month)))
 238                    (day (concat "\\*\\|0*" (int-to-string day)))
 239                    (year
 240                     (concat
 241                      "\\*\\|0*" (int-to-string year)
 242                      (if abbreviated-calendar-year
 243                          (concat "\\|" (int-to-string (% year 100)))
 244                        "")))
 245                    (regexp
 246                     (concat
 247                      "\\(\\`\\|\^M\\|\n\\)" mark "?"
 248                      (regexp-quote islamic-diary-entry-symbol)
 249                      "\\("
 250                      (mapconcat 'eval date-form "\\)\\(")
 251                      "\\)"))
 252                    (case-fold-search t))
 253                 (goto-char (point-min))
 254                 (while (re-search-forward regexp nil t)
 255                   (if backup (re-search-backward "\\<" nil t))
 256                   (if (and (or (char-equal (preceding-char) ?\^M)
 257                                (char-equal (preceding-char) ?\n))
 258                            (not (looking-at " \\|\^I")))
 259                       ;; Diary entry that consists only of date.
 260                       (backward-char 1)
 261                     ;; Found a nonempty diary entry--make it visible and
 262                     ;; add it to the list.
 263                     (let ((entry-start (point))
 264                           (date-start))
 265                       (re-search-backward "\^M\\|\n\\|\\`")
 266                       (setq date-start (point))
 267                       (re-search-forward "\^M\\|\n" nil t 2)
 268                       (while (looking-at " \\|\^I")
 269                         (re-search-forward "\^M\\|\n" nil t))
 270                       (backward-char 1)
 271                       (subst-char-in-region date-start (point) ?\^M ?\n t)
 272                       (add-to-diary-list
 273                        gdate
 274                        (buffer-substring-no-properties entry-start (point))
 275                        (buffer-substring-no-properties
 276                         (1+ date-start) (1- entry-start))
 277                        (copy-marker entry-start))))))
 278               (setq d (cdr d))))
 279           (setq gdate
 280                 (calendar-gregorian-from-absolute
 281                  (1+ (calendar-absolute-from-gregorian gdate)))))
 282         (set-buffer-modified-p diary-modified))
 283     (goto-char (point-min))))
 284
 285 (declare-function diary-name-pattern "diary-lib"
 286                   (string-array &optional abbrev-array paren))
 287
 288 (declare-function mark-calendar-days-named "diary-lib"
 289                   (dayname &optional color))
 290
 291 (defun mark-islamic-diary-entries ()
 292   "Mark days in the calendar window that have Islamic date diary entries.
 293 Each entry in `diary-file' (or included files) visible in the calendar window
 294 is marked.  Islamic date entries are prefaced by `islamic-diary-entry-symbol'
 295 \(normally an `I').  The same `diary-date-forms' govern the style of the Islamic
 296 calendar entries, except that the Islamic month names must be spelled in full.
 297 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 298 Dhu al-Hijjah.  Islamic date diary entries that begin with a
 299 `diary-nonmarking-symbol' will not be marked in the calendar.  This function is
 300 provided for use as part of the `nongregorian-diary-marking-hook'."
 301   (let ((d diary-date-forms))
 302     (while d
 303       (let*
 304           ((date-form (if (equal (car (car d)) 'backup)
 305                           (cdr (car d))
 306                         (car d)))       ; ignore 'backup directive
 307            (dayname (diary-name-pattern calendar-day-name-array
 308                                         calendar-day-abbrev-array))
 309            (monthname
 310             (format "%s\\|\\*"
 311                     (diary-name-pattern calendar-islamic-month-name-array)))
 312            (month "[0-9]+\\|\\*")
 313            (day "[0-9]+\\|\\*")
 314            (year "[0-9]+\\|\\*")
 315            (l (length date-form))
 316            (d-name-pos (- l (length (memq 'dayname date-form))))
 317            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 318            (m-name-pos (- l (length (memq 'monthname date-form))))
 319            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 320            (d-pos (- l (length (memq 'day date-form))))
 321            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 322            (m-pos (- l (length (memq 'month date-form))))
 323            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 324            (y-pos (- l (length (memq 'year date-form))))
 325            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 326            (regexp
 327             (concat
 328              "\\(\\`\\|\^M\\|\n\\)"
 329              (regexp-quote islamic-diary-entry-symbol)
 330              "\\("
 331              (mapconcat 'eval date-form "\\)\\(")
 332              "\\)"))
 333            (case-fold-search t))
 334         (goto-char (point-min))
 335         (while (re-search-forward regexp nil t)
 336           (let* ((dd-name
 337                   (if d-name-pos
 338                       (buffer-substring
 339                        (match-beginning d-name-pos)
 340                        (match-end d-name-pos))))
 341                  (mm-name
 342                   (if m-name-pos
 343                       (buffer-substring
 344                        (match-beginning m-name-pos)
 345                        (match-end m-name-pos))))
 346                  (mm (string-to-number
 347                       (if m-pos
 348                           (buffer-substring
 349                            (match-beginning m-pos)
 350                            (match-end m-pos))
 351                         "")))
 352                  (dd (string-to-number
 353                       (if d-pos
 354                           (buffer-substring
 355                            (match-beginning d-pos)
 356                            (match-end d-pos))
 357                         "")))
 358                  (y-str (if y-pos
 359                             (buffer-substring
 360                              (match-beginning y-pos)
 361                              (match-end y-pos))))
 362                  (yy (if (not y-str)
 363                          0
 364                        (if (and (= (length y-str) 2)
 365                                 abbreviated-calendar-year)
 366                            (let* ((current-y
 367                                    (extract-calendar-year
 368                                     (calendar-islamic-from-absolute
 369                                      (calendar-absolute-from-gregorian
 370                                       (calendar-current-date)))))
 371                                   (y (+ (string-to-number y-str)
 372                                         (* 100 (/ current-y 100)))))
 373                              (if (> (- y current-y) 50)
 374                                  (- y 100)
 375                                (if (> (- current-y y) 50)
 376                                    (+ y 100)
 377                                  y)))
 378                          (string-to-number y-str)))))
 379             (if dd-name
 380                 (mark-calendar-days-named
 381                  (cdr (assoc-string dd-name
 382                                          (calendar-make-alist
 383                                           calendar-day-name-array
 384                                           0 nil calendar-day-abbrev-array) t)))
 385               (if mm-name
 386                   (setq mm (if (string-equal mm-name "*") 0
 387                              (cdr (assoc-string
 388                                    mm-name
 389                                    (calendar-make-alist
 390                                     calendar-islamic-month-name-array) t)))))
 391               (mark-islamic-calendar-date-pattern mm dd yy)))))
 392       (setq d (cdr d)))))
 393
 394 (defun mark-islamic-calendar-date-pattern (month day year)
 395   "Mark dates in calendar window that conform to Islamic 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 (not (zerop month)) (not (zerop day)))
 400         (if (not (zerop year))
 401             ;; Fully specified Islamic date.
 402             (let ((date (calendar-gregorian-from-absolute
 403                          (calendar-absolute-from-islamic
 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* ((islamic-date (calendar-islamic-from-absolute
 409                                 (calendar-absolute-from-gregorian
 410                                  (list displayed-month 15 displayed-year))))
 411                  (m (extract-calendar-month islamic-date))
 412                  (y (extract-calendar-year islamic-date))
 413                  (date))
 414             (if (< m 1)
 415                 nil                ;   Islamic calendar doesn't apply
 416               (increment-calendar-month m y (- 10 month))
 417               (if (> m 7)             ;  Islamic date might be visible
 418                   (let ((date (calendar-gregorian-from-absolute
 419                                (calendar-absolute-from-islamic
 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* ((i-date (calendar-islamic-from-absolute date))
 440                  (i-month (extract-calendar-month i-date))
 441                  (i-day (extract-calendar-day i-date))
 442                  (i-year (extract-calendar-year i-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 ;;;###autoload
 453 (defun insert-islamic-diary-entry (arg)
 454   "Insert a diary entry.
 455 For the Islamic date corresponding to the date indicated by point.
 456 Prefix argument ARG makes the entry nonmarking."
 457   (interactive "P")
 458   (let* ((calendar-month-name-array calendar-islamic-month-name-array))
 459     (make-diary-entry
 460      (concat
 461       islamic-diary-entry-symbol
 462       (calendar-date-string
 463        (calendar-islamic-from-absolute
 464         (calendar-absolute-from-gregorian
 465          (calendar-cursor-to-date t)))
 466        nil t))
 467      arg)))
 468
 469 ;;;###autoload
 470 (defun insert-monthly-islamic-diary-entry (arg)
 471   "Insert a monthly diary entry.
 472 For the day of the Islamic month corresponding to the date indicated by point.
 473 Prefix argument ARG makes the entry nonmarking."
 474   (interactive "P")
 475   (let* ((calendar-date-display-form
 476           (if european-calendar-style '(day " * ") '("* " day )))
 477          (calendar-month-name-array calendar-islamic-month-name-array))
 478     (make-diary-entry
 479      (concat
 480       islamic-diary-entry-symbol
 481       (calendar-date-string
 482        (calendar-islamic-from-absolute
 483         (calendar-absolute-from-gregorian
 484          (calendar-cursor-to-date t)))))
 485      arg)))
 486
 487 ;;;###autoload
 488 (defun insert-yearly-islamic-diary-entry (arg)
 489   "Insert an annual diary entry.
 490 For the day of the Islamic year corresponding to the date indicated by point.
 491 Prefix argument ARG makes the entry nonmarking."
 492   (interactive "P")
 493   (let* ((calendar-date-display-form
 494           (if european-calendar-style
 495               '(day " " monthname)
 496             '(monthname " " day)))
 497          (calendar-month-name-array calendar-islamic-month-name-array))
 498     (make-diary-entry
 499      (concat
 500       islamic-diary-entry-symbol
 501       (calendar-date-string
 502        (calendar-islamic-from-absolute
 503         (calendar-absolute-from-gregorian
 504          (calendar-cursor-to-date t)))))
 505      arg)))
 506
 507 (defvar date)
 508
 509 ;; To be called from diary-sexp-entry, where DATE, ENTRY are bound.
 510 (defun diary-islamic-date ()
 511   "Islamic calendar equivalent of date diary entry."
 512   (let ((i (calendar-islamic-date-string date)))
 513     (if (string-equal i "")
 514         "Date is pre-Islamic"
 515       (format "Islamic date (until sunset): %s" i))))
 516
 517 (provide 'cal-islam)
 518
 519 ;; Local Variables:
 520 ;; generated-autoload-file: "cal-loaddefs.el"
 521 ;; End:
 522
 523 ;; arch-tag: a951b6c1-6f47-48d5-bac3-1b505cd719f7
 524 ;;; cal-islam.el ends here