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