lisp/calendar/cal-islam.el

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