code.delx.au - gnu-emacs/blob - lisp/calendar/cal-islam.el

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