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
 267                         (buffer-substring-no-properties entry-start (point))
 268                         (buffer-substring-no-properties
 269                          (1+ date-start) (1- entry-start)))))))
 270                (setq d (cdr d))))
 271            (setq gdate
 272                  (calendar-gregorian-from-absolute
 273                   (1+ (calendar-absolute-from-gregorian gdate)))))
 274            (set-buffer-modified-p diary-modified))
 275         (goto-char (point-min))))
 276
 277 (defun mark-islamic-diary-entries ()
 278   "Mark days in the calendar window that have Islamic date diary entries.
 279 Each entry in diary-file (or included files) visible in the calendar window
 280 is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
 281 \(normally an `I').  The same diary-date-forms govern the style of the Islamic
 282 calendar entries, except that the Islamic month names must be spelled in full.
 283 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 284 Dhu al-Hijjah.  Islamic date diary entries that begin with a
 285 diary-nonmarking-symbol will not be marked in the calendar.  This function is
 286 provided for use as part of the nongregorian-diary-marking-hook."
 287   (let ((d diary-date-forms))
 288     (while d
 289       (let*
 290           ((date-form (if (equal (car (car d)) 'backup)
 291                           (cdr (car d))
 292                         (car d)));; ignore 'backup directive
 293            (dayname (diary-name-pattern calendar-day-name-array))
 294            (monthname
 295             (concat
 296              (diary-name-pattern calendar-islamic-month-name-array t)
 297              "\\|\\*"))
 298            (month "[0-9]+\\|\\*")
 299            (day "[0-9]+\\|\\*")
 300            (year "[0-9]+\\|\\*")
 301            (l (length date-form))
 302            (d-name-pos (- l (length (memq 'dayname date-form))))
 303            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 304            (m-name-pos (- l (length (memq 'monthname date-form))))
 305            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 306            (d-pos (- l (length (memq 'day date-form))))
 307            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 308            (m-pos (- l (length (memq 'month date-form))))
 309            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 310            (y-pos (- l (length (memq 'year date-form))))
 311            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 312            (regexp
 313             (concat
 314              "\\(\\`\\|\^M\\|\n\\)"
 315              (regexp-quote islamic-diary-entry-symbol)
 316              "\\("
 317              (mapconcat 'eval date-form "\\)\\(")
 318              "\\)"))
 319            (case-fold-search t))
 320         (goto-char (point-min))
 321         (while (re-search-forward regexp nil t)
 322           (let* ((dd-name
 323                   (if d-name-pos
 324                       (buffer-substring
 325                        (match-beginning d-name-pos)
 326                        (match-end d-name-pos))))
 327                  (mm-name
 328                   (if m-name-pos
 329                       (buffer-substring
 330                        (match-beginning m-name-pos)
 331                        (match-end m-name-pos))))
 332                  (mm (string-to-int
 333                       (if m-pos
 334                           (buffer-substring
 335                            (match-beginning m-pos)
 336                            (match-end m-pos))
 337                         "")))
 338                  (dd (string-to-int
 339                       (if d-pos
 340                           (buffer-substring
 341                            (match-beginning d-pos)
 342                            (match-end d-pos))
 343                         "")))
 344                  (y-str (if y-pos
 345                             (buffer-substring
 346                              (match-beginning y-pos)
 347                              (match-end y-pos))))
 348                  (yy (if (not y-str)
 349                          0
 350                        (if (and (= (length y-str) 2)
 351                                 abbreviated-calendar-year)
 352                            (let* ((current-y
 353                                    (extract-calendar-year
 354                                     (calendar-islamic-from-absolute
 355                                      (calendar-absolute-from-gregorian
 356                                       (calendar-current-date)))))
 357                                   (y (+ (string-to-int y-str)
 358                                         (* 100 (/ current-y 100)))))
 359                              (if (> (- y current-y) 50)
 360                                  (- y 100)
 361                                (if (> (- current-y y) 50)
 362                                    (+ y 100)
 363                                  y)))
 364                          (string-to-int y-str)))))
 365             (if dd-name
 366                 (mark-calendar-days-named
 367                  (cdr (assoc (capitalize (substring dd-name 0 3))
 368                              (calendar-make-alist
 369                                calendar-day-name-array
 370                                0
 371                                '(lambda (x) (substring x 0 3))))))
 372               (if mm-name
 373                   (if (string-equal mm-name "*")
 374                       (setq mm 0)
 375                     (setq mm
 376                           (cdr (assoc
 377                                 (capitalize mm-name)
 378                                 (calendar-make-alist
 379                                   calendar-islamic-month-name-array))))))
 380               (mark-islamic-calendar-date-pattern mm dd yy)))))
 381       (setq d (cdr d)))))
 382
 383 (defun mark-islamic-calendar-date-pattern (month day year)
 384   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
 385 A value of 0 in any position is a wildcard."
 386   (save-excursion
 387     (set-buffer calendar-buffer)
 388     (if (and (/= 0 month) (/= 0 day))
 389         (if (/= 0 year)
 390             ;; Fully specified Islamic date.
 391             (let ((date (calendar-gregorian-from-absolute
 392                          (calendar-absolute-from-islamic
 393                           (list month day year)))))
 394               (if (calendar-date-is-visible-p date)
 395                   (mark-visible-calendar-date date)))
 396           ;; Month and day in any year--this taken from the holiday stuff.
 397           (let* ((islamic-date (calendar-islamic-from-absolute
 398                                 (calendar-absolute-from-gregorian
 399                                  (list displayed-month 15 displayed-year))))
 400                  (m (extract-calendar-month islamic-date))
 401                  (y (extract-calendar-year islamic-date))
 402                  (date))
 403             (if (< m 1)
 404                 nil;;   Islamic calendar doesn't apply.
 405               (increment-calendar-month m y (- 10 month))
 406               (if (> m 7);;  Islamic date might be visible
 407                   (let ((date (calendar-gregorian-from-absolute
 408                                (calendar-absolute-from-islamic
 409                                 (list month day y)))))
 410                     (if (calendar-date-is-visible-p date)
 411                         (mark-visible-calendar-date date)))))))
 412       ;; Not one of the simple cases--check all visible dates for match.
 413       ;; Actually, the following code takes care of ALL of the cases, but
 414       ;; it's much too slow to be used for the simple (common) cases.
 415       (let ((m displayed-month)
 416             (y displayed-year)
 417             (first-date)
 418             (last-date))
 419         (increment-calendar-month m y -1)
 420         (setq first-date
 421               (calendar-absolute-from-gregorian
 422                (list m 1 y)))
 423         (increment-calendar-month m y 2)
 424         (setq last-date
 425               (calendar-absolute-from-gregorian
 426                (list m (calendar-last-day-of-month m y) y)))
 427         (calendar-for-loop date from first-date to last-date do
 428           (let* ((i-date (calendar-islamic-from-absolute date))
 429                  (i-month (extract-calendar-month i-date))
 430                  (i-day (extract-calendar-day i-date))
 431                  (i-year (extract-calendar-year i-date)))
 432             (and (or (zerop month)
 433                      (= month i-month))
 434                  (or (zerop day)
 435                      (= day i-day))
 436                  (or (zerop year)
 437                      (= year i-year))
 438                  (mark-visible-calendar-date
 439                   (calendar-gregorian-from-absolute date)))))))))
 440
 441 (defun insert-islamic-diary-entry (arg)
 442   "Insert a diary entry.
 443 For the Islamic date corresponding to the date indicated by point.
 444 Prefix arg will make the entry nonmarking."
 445   (interactive "P")
 446   (let* ((calendar-month-name-array calendar-islamic-month-name-array))
 447     (make-diary-entry
 448      (concat
 449       islamic-diary-entry-symbol
 450       (calendar-date-string
 451        (calendar-islamic-from-absolute
 452         (calendar-absolute-from-gregorian
 453          (calendar-cursor-to-date t)))
 454        nil t))
 455      arg)))
 456
 457 (defun insert-monthly-islamic-diary-entry (arg)
 458   "Insert a monthly diary entry.
 459 For the day of the Islamic month corresponding to the date indicated by point.
 460 Prefix arg will make the entry nonmarking."
 461   (interactive "P")
 462   (let* ((calendar-date-display-form
 463           (if european-calendar-style '(day " * ") '("* " day )))
 464          (calendar-month-name-array calendar-islamic-month-name-array))
 465     (make-diary-entry
 466      (concat
 467       islamic-diary-entry-symbol
 468       (calendar-date-string
 469        (calendar-islamic-from-absolute
 470         (calendar-absolute-from-gregorian
 471          (calendar-cursor-to-date t)))))
 472      arg)))
 473
 474 (defun insert-yearly-islamic-diary-entry (arg)
 475   "Insert an annual diary entry.
 476 For the day of the Islamic year corresponding to the date indicated by point.
 477 Prefix arg will make the entry nonmarking."
 478   (interactive "P")
 479   (let* ((calendar-date-display-form
 480           (if european-calendar-style
 481               '(day " " monthname)
 482             '(monthname " " day)))
 483          (calendar-month-name-array calendar-islamic-month-name-array))
 484     (make-diary-entry
 485      (concat
 486       islamic-diary-entry-symbol
 487       (calendar-date-string
 488        (calendar-islamic-from-absolute
 489         (calendar-absolute-from-gregorian
 490          (calendar-cursor-to-date t)))))
 491      arg)))
 492
 493 (provide 'cal-islam)
 494
 495 ;;; cal-islam.el ends here