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 ;;   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   "Returns 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 (defun calendar-islamic-date-string (&optional date)
 123   "String of Islamic date before sunset of Gregorian DATE.
 124 Returns the empty string if DATE is pre-Islamic.
 125 Defaults to today's date if DATE is not given.
 126 Driven by the variable `calendar-date-display-form'."
 127   (let ((calendar-month-name-array calendar-islamic-month-name-array)
 128         (islamic-date (calendar-islamic-from-absolute
 129                        (calendar-absolute-from-gregorian
 130                         (or date (calendar-current-date))))))
 131     (if (< (extract-calendar-year islamic-date) 1)
 132         ""
 133       (calendar-date-string islamic-date nil t))))
 134
 135 (defun calendar-print-islamic-date ()
 136   "Show the Islamic calendar equivalent of the date under the cursor."
 137   (interactive)
 138   (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
 139     (if (string-equal i "")
 140         (message "Date is pre-Islamic")
 141       (message "Islamic date (until sunset): %s" i))))
 142
 143 (defun calendar-goto-islamic-date (date &optional noecho)
 144   "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t."
 145   (interactive
 146    (let* ((today (calendar-current-date))
 147           (year (calendar-read
 148                  "Islamic calendar year (>0): "
 149                  '(lambda (x) (> x 0))
 150                  (int-to-string
 151                   (extract-calendar-year
 152                    (calendar-islamic-from-absolute
 153                     (calendar-absolute-from-gregorian today))))))
 154           (month-array calendar-islamic-month-name-array)
 155           (completion-ignore-case t)
 156           (month (cdr (assoc-string
 157                         (completing-read
 158                          "Islamic calendar month name: "
 159                          (mapcar 'list (append month-array nil))
 160                          nil t)
 161                        (calendar-make-alist month-array 1) t)))
 162           (last (islamic-calendar-last-day-of-month month year))
 163           (day (calendar-read
 164                 (format "Islamic calendar day (1-%d): " last)
 165                 '(lambda (x) (and (< 0 x) (<= x last))))))
 166      (list (list month day year))))
 167   (calendar-goto-date (calendar-gregorian-from-absolute
 168                        (calendar-absolute-from-islamic date)))
 169   (or noecho (calendar-print-islamic-date)))
 170
 171 (defun diary-islamic-date ()
 172   "Islamic calendar equivalent of date diary entry."
 173   (let ((i (calendar-islamic-date-string date)))
 174     (if (string-equal i "")
 175         "Date is pre-Islamic"
 176       (format "Islamic date (until sunset): %s" i))))
 177
 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     (if (< m 1)
 190         nil;;   Islamic calendar doesn't apply.
 191       (increment-calendar-month m y (- 10 month))
 192       (if (> m 7);;  Islamic date might be visible
 193           (let ((date (calendar-gregorian-from-absolute
 194                        (calendar-absolute-from-islamic (list month day y)))))
 195             (if (calendar-date-is-visible-p date)
 196                 (list (list date string))))))))
 197
 198 (defun list-islamic-diary-entries ()
 199   "Add any Islamic date entries from the diary file to `diary-entries-list'.
 200 Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
 201 \(normally an `I').  The same diary date forms govern the style of the Islamic
 202 calendar entries, except that the Islamic month names must be spelled in full.
 203 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 204 Dhu al-Hijjah.  If an Islamic date diary entry begins with a
 205 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
 206 not be marked in the calendar.  This function is provided for use with the
 207 `nongregorian-diary-listing-hook'."
 208   (if (< 0 number)
 209       (let ((buffer-read-only nil)
 210             (diary-modified (buffer-modified-p))
 211             (gdate original-date)
 212             (mark (regexp-quote diary-nonmarking-symbol)))
 213         (dotimes (idummy number)
 214           (let* ((d diary-date-forms)
 215                  (idate (calendar-islamic-from-absolute
 216                          (calendar-absolute-from-gregorian gdate)))
 217                  (month (extract-calendar-month idate))
 218                  (day (extract-calendar-day idate))
 219                  (year (extract-calendar-year idate)))
 220             (while d
 221               (let*
 222                   ((date-form (if (equal (car (car d)) 'backup)
 223                                   (cdr (car d))
 224                                 (car d)))
 225                    (backup (equal (car (car d)) 'backup))
 226                    (dayname
 227                     (format "%s\\|%s\\.?"
 228                             (calendar-day-name gdate)
 229                             (calendar-day-name gdate 'abbrev)))
 230                    (calendar-month-name-array
 231                     calendar-islamic-month-name-array)
 232                    (monthname
 233                     (concat
 234                      "\\*\\|"
 235                      (calendar-month-name month)))
 236                    (month (concat "\\*\\|0*" (int-to-string month)))
 237                    (day (concat "\\*\\|0*" (int-to-string day)))
 238                    (year
 239                     (concat
 240                      "\\*\\|0*" (int-to-string year)
 241                      (if abbreviated-calendar-year
 242                          (concat "\\|" (int-to-string (% year 100)))
 243                        "")))
 244                    (regexp
 245                     (concat
 246                      "\\(\\`\\|\^M\\|\n\\)" mark "?"
 247                      (regexp-quote islamic-diary-entry-symbol)
 248                      "\\("
 249                      (mapconcat 'eval date-form "\\)\\(")
 250                      "\\)"))
 251                    (case-fold-search t))
 252                 (goto-char (point-min))
 253                 (while (re-search-forward regexp nil t)
 254                   (if backup (re-search-backward "\\<" nil t))
 255                   (if (and (or (char-equal (preceding-char) ?\^M)
 256                                (char-equal (preceding-char) ?\n))
 257                            (not (looking-at " \\|\^I")))
 258                       ;;  Diary entry that consists only of date.
 259                       (backward-char 1)
 260                     ;;  Found a nonempty diary entry--make it visible and
 261                     ;;  add it to the list.
 262                     (let ((entry-start (point))
 263                           (date-start))
 264                       (re-search-backward "\^M\\|\n\\|\\`")
 265                       (setq date-start (point))
 266                       (re-search-forward "\^M\\|\n" nil t 2)
 267                       (while (looking-at " \\|\^I")
 268                         (re-search-forward "\^M\\|\n" nil t))
 269                       (backward-char 1)
 270                       (subst-char-in-region date-start (point) ?\^M ?\n t)
 271                       (add-to-diary-list
 272                        gdate
 273                        (buffer-substring-no-properties entry-start (point))
 274                        (buffer-substring-no-properties
 275                         (1+ date-start) (1- entry-start))
 276                        (copy-marker entry-start))))))
 277               (setq d (cdr d))))
 278           (setq gdate
 279                 (calendar-gregorian-from-absolute
 280                  (1+ (calendar-absolute-from-gregorian gdate)))))
 281         (set-buffer-modified-p diary-modified))
 282     (goto-char (point-min))))
 283
 284 (defun mark-islamic-diary-entries ()
 285   "Mark days in the calendar window that have Islamic date diary entries.
 286 Each entry in diary-file (or included files) visible in the calendar window
 287 is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
 288 \(normally an `I').  The same diary-date-forms govern the style of the Islamic
 289 calendar entries, except that the Islamic month names must be spelled in full.
 290 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 291 Dhu al-Hijjah.  Islamic date diary entries that begin with a
 292 diary-nonmarking-symbol will not be marked in the calendar.  This function is
 293 provided for use as part of the nongregorian-diary-marking-hook."
 294   (let ((d diary-date-forms))
 295     (while d
 296       (let*
 297           ((date-form (if (equal (car (car d)) 'backup)
 298                           (cdr (car d))
 299                         (car d)));; ignore 'backup directive
 300            (dayname (diary-name-pattern calendar-day-name-array
 301                                         calendar-day-abbrev-array))
 302            (monthname
 303             (format "%s\\|\\*"
 304                     (diary-name-pattern calendar-islamic-month-name-array)))
 305            (month "[0-9]+\\|\\*")
 306            (day "[0-9]+\\|\\*")
 307            (year "[0-9]+\\|\\*")
 308            (l (length date-form))
 309            (d-name-pos (- l (length (memq 'dayname date-form))))
 310            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 311            (m-name-pos (- l (length (memq 'monthname date-form))))
 312            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 313            (d-pos (- l (length (memq 'day date-form))))
 314            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 315            (m-pos (- l (length (memq 'month date-form))))
 316            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 317            (y-pos (- l (length (memq 'year date-form))))
 318            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 319            (regexp
 320             (concat
 321              "\\(\\`\\|\^M\\|\n\\)"
 322              (regexp-quote islamic-diary-entry-symbol)
 323              "\\("
 324              (mapconcat 'eval date-form "\\)\\(")
 325              "\\)"))
 326            (case-fold-search t))
 327         (goto-char (point-min))
 328         (while (re-search-forward regexp nil t)
 329           (let* ((dd-name
 330                   (if d-name-pos
 331                       (buffer-substring
 332                        (match-beginning d-name-pos)
 333                        (match-end d-name-pos))))
 334                  (mm-name
 335                   (if m-name-pos
 336                       (buffer-substring
 337                        (match-beginning m-name-pos)
 338                        (match-end m-name-pos))))
 339                  (mm (string-to-number
 340                       (if m-pos
 341                           (buffer-substring
 342                            (match-beginning m-pos)
 343                            (match-end m-pos))
 344                         "")))
 345                  (dd (string-to-number
 346                       (if d-pos
 347                           (buffer-substring
 348                            (match-beginning d-pos)
 349                            (match-end d-pos))
 350                         "")))
 351                  (y-str (if y-pos
 352                             (buffer-substring
 353                              (match-beginning y-pos)
 354                              (match-end y-pos))))
 355                  (yy (if (not y-str)
 356                          0
 357                        (if (and (= (length y-str) 2)
 358                                 abbreviated-calendar-year)
 359                            (let* ((current-y
 360                                    (extract-calendar-year
 361                                     (calendar-islamic-from-absolute
 362                                      (calendar-absolute-from-gregorian
 363                                       (calendar-current-date)))))
 364                                   (y (+ (string-to-number y-str)
 365                                         (* 100 (/ current-y 100)))))
 366                              (if (> (- y current-y) 50)
 367                                  (- y 100)
 368                                (if (> (- current-y y) 50)
 369                                    (+ y 100)
 370                                  y)))
 371                          (string-to-number y-str)))))
 372             (if dd-name
 373                 (mark-calendar-days-named
 374                  (cdr (assoc-string dd-name
 375                                          (calendar-make-alist
 376                                           calendar-day-name-array
 377                                           0 nil calendar-day-abbrev-array) t)))
 378               (if mm-name
 379                   (setq mm (if (string-equal mm-name "*") 0
 380                              (cdr (assoc-string
 381                                    mm-name
 382                                    (calendar-make-alist
 383                                     calendar-islamic-month-name-array) t)))))
 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 ;;; arch-tag: a951b6c1-6f47-48d5-bac3-1b505cd719f7
 500 ;;; cal-islam.el ends here