lisp/calendar/cal-islam.el

   1 ;;; cal-islam.el --- calendar functions for the Islamic calendar
   2
   3 ;; Copyright (C) 1995, 1997, 2001, 2003 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 (defvar displayed-month)
  44 (defvar displayed-year)
  45
  46 (require 'cal-julian)
  47
  48 (defvar calendar-islamic-month-name-array
  49   ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II"
  50    "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"]
  51 "Array of strings giving the names of the Islamic months.")
  52
  53 (defvar calendar-islamic-epoch (calendar-absolute-from-julian '(7 16 622))
  54   "Absolute date of start of Islamic calendar = August 29, 284 A.D. (Julian).")
  55
  56 (defun islamic-calendar-leap-year-p (year)
  57   "Returns t if YEAR is a leap year on the Islamic calendar."
  58   (memq (% year 30)
  59         (list 2 5 7 10 13 16 18 21 24 26 29)))
  60
  61 (defun islamic-calendar-last-day-of-month (month year)
  62   "The last day in MONTH during YEAR on the Islamic calendar."
  63   (cond
  64    ((memq month (list 1 3 5 7 9 11)) 30)
  65    ((memq month (list 2 4 6 8 10)) 29)
  66    (t (if (islamic-calendar-leap-year-p year) 30 29))))
  67
  68 (defun islamic-calendar-day-number (date)
  69   "Return the day number within the year of the Islamic date DATE."
  70     (let* ((month (extract-calendar-month date))
  71            (day (extract-calendar-day date)))
  72       (+ (* 30 (/ month 2))
  73          (* 29 (/ (1- month) 2))
  74          day)))
  75
  76 (defun calendar-absolute-from-islamic (date)
  77   "Absolute date of Islamic DATE.
  78 The absolute date is the number of days elapsed since the (imaginary)
  79 Gregorian date Sunday, December 31, 1 BC."
  80   (let* ((month (extract-calendar-month date))
  81          (day (extract-calendar-day date))
  82          (year (extract-calendar-year date))
  83          (y (% year 30))
  84          (leap-years-in-cycle
  85           (cond
  86            ((< y 3) 0)  ((< y 6) 1)  ((< y 8) 2)  ((< y 11) 3) ((< y 14) 4)
  87            ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9)
  88            (t 10))))
  89     (+ (islamic-calendar-day-number date);; days so far this year
  90        (* (1- year) 354)                 ;; days in all non-leap years
  91        (* 11 (/ year 30))                ;; leap days in complete cycles
  92        leap-years-in-cycle               ;; leap days this cycle
  93        (1- calendar-islamic-epoch))))    ;; days before start of calendar
  94
  95 (defun calendar-islamic-from-absolute (date)
  96   "Compute the Islamic date (month day year) corresponding to absolute DATE.
  97 The absolute date is the number of days elapsed since the (imaginary)
  98 Gregorian date Sunday, December 31, 1 BC."
  99   (if (< date calendar-islamic-epoch)
 100       (list 0 0 0);; pre-Islamic date
 101     (let* ((approx (/ (- date calendar-islamic-epoch)
 102                       355));; Approximation from below.
 103            (year           ;; Search forward from the approximation.
 104             (+ approx
 105                (calendar-sum y approx
 106                              (>= date (calendar-absolute-from-islamic
 107                                        (list 1 1 (1+ y))))
 108                              1)))
 109            (month          ;; Search forward from Muharram.
 110             (1+ (calendar-sum m 1
 111                               (> date
 112                                  (calendar-absolute-from-islamic
 113                                   (list m
 114                                         (islamic-calendar-last-day-of-month
 115                                          m year)
 116                                         year)))
 117                               1)))
 118            (day            ;; Calculate the day by subtraction.
 119             (- date
 120                (1- (calendar-absolute-from-islamic (list month 1 year))))))
 121       (list month day year))))
 122
 123 (defun calendar-islamic-date-string (&optional date)
 124   "String of Islamic date before sunset of Gregorian DATE.
 125 Returns the empty string if DATE is pre-Islamic.
 126 Defaults to today's date if DATE is not given.
 127 Driven by the variable `calendar-date-display-form'."
 128   (let ((calendar-month-name-array calendar-islamic-month-name-array)
 129         (islamic-date (calendar-islamic-from-absolute
 130                        (calendar-absolute-from-gregorian
 131                         (or date (calendar-current-date))))))
 132     (if (< (extract-calendar-year islamic-date) 1)
 133         ""
 134       (calendar-date-string islamic-date nil t))))
 135
 136 (defun calendar-print-islamic-date ()
 137   "Show the Islamic calendar equivalent of the date under the cursor."
 138   (interactive)
 139   (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
 140     (if (string-equal i "")
 141         (message "Date is pre-Islamic")
 142       (message "Islamic date (until sunset): %s" i))))
 143
 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-ignore-case
 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))))
 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 diary-islamic-date ()
 173   "Islamic calendar equivalent of date diary entry."
 174   (let ((i (calendar-islamic-date-string date)))
 175     (if (string-equal i "")
 176         "Date is pre-Islamic"
 177       (format "Islamic date (until sunset): %s" i))))
 178
 179 (defun holiday-islamic (month day string)
 180   "Holiday on MONTH, DAY (Islamic) called STRING.
 181 If MONTH, DAY (Islamic) is visible, the value returned is corresponding
 182 Gregorian date in the form of the list (((month day year) STRING)).  Returns
 183 nil if it is not visible in the current calendar window."
 184   (let* ((islamic-date (calendar-islamic-from-absolute
 185                         (calendar-absolute-from-gregorian
 186                          (list displayed-month 15 displayed-year))))
 187          (m (extract-calendar-month islamic-date))
 188          (y (extract-calendar-year islamic-date))
 189         (date))
 190     (if (< m 1)
 191         nil;;   Islamic calendar doesn't apply.
 192       (increment-calendar-month m y (- 10 month))
 193       (if (> m 7);;  Islamic date might be visible
 194           (let ((date (calendar-gregorian-from-absolute
 195                        (calendar-absolute-from-islamic (list month day y)))))
 196             (if (calendar-date-is-visible-p date)
 197                 (list (list date string))))))))
 198
 199 (defun list-islamic-diary-entries ()
 200   "Add any Islamic date entries from the diary file to `diary-entries-list'.
 201 Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
 202 \(normally an `I').  The same diary date forms govern the style of the Islamic
 203 calendar entries, except that the Islamic month names must be spelled in full.
 204 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 205 Dhu al-Hijjah.  If an Islamic date diary entry begins with a
 206 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
 207 not be marked in the calendar.  This function is provided for use with the
 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         (calendar-for-loop i from 1 to number do
 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 (defun mark-islamic-diary-entries ()
 286   "Mark days in the calendar window that have Islamic date diary entries.
 287 Each entry in diary-file (or included files) visible in the calendar window
 288 is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
 289 \(normally an `I').  The same diary-date-forms govern the style of the Islamic
 290 calendar entries, except that the Islamic month names must be spelled in full.
 291 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 292 Dhu al-Hijjah.  Islamic date diary entries that begin with a
 293 diary-nonmarking-symbol will not be marked in the calendar.  This function is
 294 provided for use as part of the nongregorian-diary-marking-hook."
 295   (let ((d diary-date-forms))
 296     (while d
 297       (let*
 298           ((date-form (if (equal (car (car d)) 'backup)
 299                           (cdr (car d))
 300                         (car d)));; ignore 'backup directive
 301            (dayname (diary-name-pattern calendar-day-name-array
 302                                         calendar-day-abbrev-array))
 303            (monthname
 304             (format "%s\\|\\*"
 305                     (diary-name-pattern calendar-islamic-month-name-array)))
 306            (month "[0-9]+\\|\\*")
 307            (day "[0-9]+\\|\\*")
 308            (year "[0-9]+\\|\\*")
 309            (l (length date-form))
 310            (d-name-pos (- l (length (memq 'dayname date-form))))
 311            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 312            (m-name-pos (- l (length (memq 'monthname date-form))))
 313            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 314            (d-pos (- l (length (memq 'day date-form))))
 315            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 316            (m-pos (- l (length (memq 'month date-form))))
 317            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 318            (y-pos (- l (length (memq 'year date-form))))
 319            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 320            (regexp
 321             (concat
 322              "\\(\\`\\|\^M\\|\n\\)"
 323              (regexp-quote islamic-diary-entry-symbol)
 324              "\\("
 325              (mapconcat 'eval date-form "\\)\\(")
 326              "\\)"))
 327            (case-fold-search t))
 328         (goto-char (point-min))
 329         (while (re-search-forward regexp nil t)
 330           (let* ((dd-name
 331                   (if d-name-pos
 332                       (buffer-substring
 333                        (match-beginning d-name-pos)
 334                        (match-end d-name-pos))))
 335                  (mm-name
 336                   (if m-name-pos
 337                       (buffer-substring
 338                        (match-beginning m-name-pos)
 339                        (match-end m-name-pos))))
 340                  (mm (string-to-int
 341                       (if m-pos
 342                           (buffer-substring
 343                            (match-beginning m-pos)
 344                            (match-end m-pos))
 345                         "")))
 346                  (dd (string-to-int
 347                       (if d-pos
 348                           (buffer-substring
 349                            (match-beginning d-pos)
 350                            (match-end d-pos))
 351                         "")))
 352                  (y-str (if y-pos
 353                             (buffer-substring
 354                              (match-beginning y-pos)
 355                              (match-end y-pos))))
 356                  (yy (if (not y-str)
 357                          0
 358                        (if (and (= (length y-str) 2)
 359                                 abbreviated-calendar-year)
 360                            (let* ((current-y
 361                                    (extract-calendar-year
 362                                     (calendar-islamic-from-absolute
 363                                      (calendar-absolute-from-gregorian
 364                                       (calendar-current-date)))))
 365                                   (y (+ (string-to-int y-str)
 366                                         (* 100 (/ current-y 100)))))
 367                              (if (> (- y current-y) 50)
 368                                  (- y 100)
 369                                (if (> (- current-y y) 50)
 370                                    (+ y 100)
 371                                  y)))
 372                          (string-to-int y-str)))))
 373             (if dd-name
 374                 (mark-calendar-days-named
 375                  (cdr (assoc-ignore-case dd-name
 376                                          (calendar-make-alist
 377                                           calendar-day-name-array
 378                                           0 nil calendar-day-abbrev-array))))
 379               (if mm-name
 380                   (setq mm (if (string-equal mm-name "*") 0
 381                              (cdr (assoc-ignore-case
 382                                    mm-name
 383                                    (calendar-make-alist
 384                                     calendar-islamic-month-name-array))))))
 385               (mark-islamic-calendar-date-pattern mm dd yy)))))
 386       (setq d (cdr d)))))
 387
 388 (defun mark-islamic-calendar-date-pattern (month day year)
 389   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
 390 A value of 0 in any position is a wildcard."
 391   (save-excursion
 392     (set-buffer calendar-buffer)
 393     (if (and (/= 0 month) (/= 0 day))
 394         (if (/= 0 year)
 395             ;; Fully specified Islamic date.
 396             (let ((date (calendar-gregorian-from-absolute
 397                          (calendar-absolute-from-islamic
 398                           (list month day year)))))
 399               (if (calendar-date-is-visible-p date)
 400                   (mark-visible-calendar-date date)))
 401           ;; Month and day in any year--this taken from the holiday stuff.
 402           (let* ((islamic-date (calendar-islamic-from-absolute
 403                                 (calendar-absolute-from-gregorian
 404                                  (list displayed-month 15 displayed-year))))
 405                  (m (extract-calendar-month islamic-date))
 406                  (y (extract-calendar-year islamic-date))
 407                  (date))
 408             (if (< m 1)
 409                 nil;;   Islamic calendar doesn't apply.
 410               (increment-calendar-month m y (- 10 month))
 411               (if (> m 7);;  Islamic date might be visible
 412                   (let ((date (calendar-gregorian-from-absolute
 413                                (calendar-absolute-from-islamic
 414                                 (list month day y)))))
 415                     (if (calendar-date-is-visible-p date)
 416                         (mark-visible-calendar-date date)))))))
 417       ;; Not one of the simple cases--check all visible dates for match.
 418       ;; Actually, the following code takes care of ALL of the cases, but
 419       ;; it's much too slow to be used for the simple (common) cases.
 420       (let ((m displayed-month)
 421             (y displayed-year)
 422             (first-date)
 423             (last-date))
 424         (increment-calendar-month m y -1)
 425         (setq first-date
 426               (calendar-absolute-from-gregorian
 427                (list m 1 y)))
 428         (increment-calendar-month m y 2)
 429         (setq last-date
 430               (calendar-absolute-from-gregorian
 431                (list m (calendar-last-day-of-month m y) y)))
 432         (calendar-for-loop date from first-date to last-date do
 433           (let* ((i-date (calendar-islamic-from-absolute date))
 434                  (i-month (extract-calendar-month i-date))
 435                  (i-day (extract-calendar-day i-date))
 436                  (i-year (extract-calendar-year i-date)))
 437             (and (or (zerop month)
 438                      (= month i-month))
 439                  (or (zerop day)
 440                      (= day i-day))
 441                  (or (zerop year)
 442                      (= year i-year))
 443                  (mark-visible-calendar-date
 444                   (calendar-gregorian-from-absolute date)))))))))
 445
 446 (defun insert-islamic-diary-entry (arg)
 447   "Insert a diary entry.
 448 For the Islamic date corresponding to the date indicated by point.
 449 Prefix arg will make the entry nonmarking."
 450   (interactive "P")
 451   (let* ((calendar-month-name-array calendar-islamic-month-name-array))
 452     (make-diary-entry
 453      (concat
 454       islamic-diary-entry-symbol
 455       (calendar-date-string
 456        (calendar-islamic-from-absolute
 457         (calendar-absolute-from-gregorian
 458          (calendar-cursor-to-date t)))
 459        nil t))
 460      arg)))
 461
 462 (defun insert-monthly-islamic-diary-entry (arg)
 463   "Insert a monthly diary entry.
 464 For the day of the Islamic month corresponding to the date indicated by point.
 465 Prefix arg will make the entry nonmarking."
 466   (interactive "P")
 467   (let* ((calendar-date-display-form
 468           (if european-calendar-style '(day " * ") '("* " day )))
 469          (calendar-month-name-array calendar-islamic-month-name-array))
 470     (make-diary-entry
 471      (concat
 472       islamic-diary-entry-symbol
 473       (calendar-date-string
 474        (calendar-islamic-from-absolute
 475         (calendar-absolute-from-gregorian
 476          (calendar-cursor-to-date t)))))
 477      arg)))
 478
 479 (defun insert-yearly-islamic-diary-entry (arg)
 480   "Insert an annual diary entry.
 481 For the day of the Islamic year corresponding to the date indicated by point.
 482 Prefix arg will make the entry nonmarking."
 483   (interactive "P")
 484   (let* ((calendar-date-display-form
 485           (if european-calendar-style
 486               '(day " " monthname)
 487             '(monthname " " day)))
 488          (calendar-month-name-array calendar-islamic-month-name-array))
 489     (make-diary-entry
 490      (concat
 491       islamic-diary-entry-symbol
 492       (calendar-date-string
 493        (calendar-islamic-from-absolute
 494         (calendar-absolute-from-gregorian
 495          (calendar-cursor-to-date t)))))
 496      arg)))
 497
 498 (provide 'cal-islam)
 499
 500 ;;; arch-tag: a951b6c1-6f47-48d5-bac3-1b505cd719f7
 501 ;;; cal-islam.el ends here