lisp/calendar/cal-islam.el

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