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