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, 2008
   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 ;; l-i-d-e should be called from diary code.
 199 (declare-function add-to-diary-list "diary-lib"
 200                   (date string specifier &optional marker globcolor literal))
 201
 202 (defun list-islamic-diary-entries ()
 203   "Add any Islamic date entries from the diary file to `diary-entries-list'.
 204 Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
 205 \(normally an `I').  The same diary date forms govern the style of the Islamic
 206 calendar entries, except that the Islamic month names must be spelled in full.
 207 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 208 Dhu al-Hijjah.  If an Islamic date diary entry begins with a
 209 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
 210 not be marked in the calendar.  This function is provided for use with the
 211 `nongregorian-diary-listing-hook'."
 212   (if (< 0 number)
 213       (let ((buffer-read-only nil)
 214             (diary-modified (buffer-modified-p))
 215             (gdate original-date)
 216             (mark (regexp-quote diary-nonmarking-symbol)))
 217         (dotimes (idummy number)
 218           (let* ((d diary-date-forms)
 219                  (idate (calendar-islamic-from-absolute
 220                          (calendar-absolute-from-gregorian gdate)))
 221                  (month (extract-calendar-month idate))
 222                  (day (extract-calendar-day idate))
 223                  (year (extract-calendar-year idate)))
 224             (while d
 225               (let*
 226                   ((date-form (if (equal (car (car d)) 'backup)
 227                                   (cdr (car d))
 228                                 (car d)))
 229                    (backup (equal (car (car d)) 'backup))
 230                    (dayname
 231                     (format "%s\\|%s\\.?"
 232                             (calendar-day-name gdate)
 233                             (calendar-day-name gdate 'abbrev)))
 234                    (calendar-month-name-array
 235                     calendar-islamic-month-name-array)
 236                    (monthname
 237                     (concat
 238                      "\\*\\|"
 239                      (calendar-month-name month)))
 240                    (month (concat "\\*\\|0*" (int-to-string month)))
 241                    (day (concat "\\*\\|0*" (int-to-string day)))
 242                    (year
 243                     (concat
 244                      "\\*\\|0*" (int-to-string year)
 245                      (if abbreviated-calendar-year
 246                          (concat "\\|" (int-to-string (% year 100)))
 247                        "")))
 248                    (regexp
 249                     (concat
 250                      "\\(\\`\\|\^M\\|\n\\)" mark "?"
 251                      (regexp-quote islamic-diary-entry-symbol)
 252                      "\\("
 253                      (mapconcat 'eval date-form "\\)\\(")
 254                      "\\)"))
 255                    (case-fold-search t))
 256                 (goto-char (point-min))
 257                 (while (re-search-forward regexp nil t)
 258                   (if backup (re-search-backward "\\<" nil t))
 259                   (if (and (or (char-equal (preceding-char) ?\^M)
 260                                (char-equal (preceding-char) ?\n))
 261                            (not (looking-at " \\|\^I")))
 262                       ;;  Diary entry that consists only of date.
 263                       (backward-char 1)
 264                     ;;  Found a nonempty diary entry--make it visible and
 265                     ;;  add it to the list.
 266                     (let ((entry-start (point))
 267                           (date-start))
 268                       (re-search-backward "\^M\\|\n\\|\\`")
 269                       (setq date-start (point))
 270                       (re-search-forward "\^M\\|\n" nil t 2)
 271                       (while (looking-at " \\|\^I")
 272                         (re-search-forward "\^M\\|\n" nil t))
 273                       (backward-char 1)
 274                       (subst-char-in-region date-start (point) ?\^M ?\n t)
 275                       (add-to-diary-list
 276                        gdate
 277                        (buffer-substring-no-properties entry-start (point))
 278                        (buffer-substring-no-properties
 279                         (1+ date-start) (1- entry-start))
 280                        (copy-marker entry-start))))))
 281               (setq d (cdr d))))
 282           (setq gdate
 283                 (calendar-gregorian-from-absolute
 284                  (1+ (calendar-absolute-from-gregorian gdate)))))
 285         (set-buffer-modified-p diary-modified))
 286     (goto-char (point-min))))
 287
 288 (declare-function diary-name-pattern "diary-lib"
 289                   (string-array &optional abbrev-array paren))
 290
 291 (declare-function mark-calendar-days-named "diary-lib"
 292                   (dayname &optional color))
 293
 294 (defun mark-islamic-diary-entries ()
 295   "Mark days in the calendar window that have Islamic date diary entries.
 296 Each entry in diary-file (or included files) visible in the calendar window
 297 is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
 298 \(normally an `I').  The same diary-date-forms govern the style of the Islamic
 299 calendar entries, except that the Islamic month names must be spelled in full.
 300 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
 301 Dhu al-Hijjah.  Islamic date diary entries that begin with a
 302 diary-nonmarking-symbol will not be marked in the calendar.  This function is
 303 provided for use as part of the nongregorian-diary-marking-hook."
 304   (let ((d diary-date-forms))
 305     (while d
 306       (let*
 307           ((date-form (if (equal (car (car d)) 'backup)
 308                           (cdr (car d))
 309                         (car d)));; ignore 'backup directive
 310            (dayname (diary-name-pattern calendar-day-name-array
 311                                         calendar-day-abbrev-array))
 312            (monthname
 313             (format "%s\\|\\*"
 314                     (diary-name-pattern calendar-islamic-month-name-array)))
 315            (month "[0-9]+\\|\\*")
 316            (day "[0-9]+\\|\\*")
 317            (year "[0-9]+\\|\\*")
 318            (l (length date-form))
 319            (d-name-pos (- l (length (memq 'dayname date-form))))
 320            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 321            (m-name-pos (- l (length (memq 'monthname date-form))))
 322            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 323            (d-pos (- l (length (memq 'day date-form))))
 324            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 325            (m-pos (- l (length (memq 'month date-form))))
 326            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 327            (y-pos (- l (length (memq 'year date-form))))
 328            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 329            (regexp
 330             (concat
 331              "\\(\\`\\|\^M\\|\n\\)"
 332              (regexp-quote islamic-diary-entry-symbol)
 333              "\\("
 334              (mapconcat 'eval date-form "\\)\\(")
 335              "\\)"))
 336            (case-fold-search t))
 337         (goto-char (point-min))
 338         (while (re-search-forward regexp nil t)
 339           (let* ((dd-name
 340                   (if d-name-pos
 341                       (buffer-substring
 342                        (match-beginning d-name-pos)
 343                        (match-end d-name-pos))))
 344                  (mm-name
 345                   (if m-name-pos
 346                       (buffer-substring
 347                        (match-beginning m-name-pos)
 348                        (match-end m-name-pos))))
 349                  (mm (string-to-number
 350                       (if m-pos
 351                           (buffer-substring
 352                            (match-beginning m-pos)
 353                            (match-end m-pos))
 354                         "")))
 355                  (dd (string-to-number
 356                       (if d-pos
 357                           (buffer-substring
 358                            (match-beginning d-pos)
 359                            (match-end d-pos))
 360                         "")))
 361                  (y-str (if y-pos
 362                             (buffer-substring
 363                              (match-beginning y-pos)
 364                              (match-end y-pos))))
 365                  (yy (if (not y-str)
 366                          0
 367                        (if (and (= (length y-str) 2)
 368                                 abbreviated-calendar-year)
 369                            (let* ((current-y
 370                                    (extract-calendar-year
 371                                     (calendar-islamic-from-absolute
 372                                      (calendar-absolute-from-gregorian
 373                                       (calendar-current-date)))))
 374                                   (y (+ (string-to-number y-str)
 375                                         (* 100 (/ current-y 100)))))
 376                              (if (> (- y current-y) 50)
 377                                  (- y 100)
 378                                (if (> (- current-y y) 50)
 379                                    (+ y 100)
 380                                  y)))
 381                          (string-to-number y-str)))))
 382             (if dd-name
 383                 (mark-calendar-days-named
 384                  (cdr (assoc-string dd-name
 385                                          (calendar-make-alist
 386                                           calendar-day-name-array
 387                                           0 nil calendar-day-abbrev-array) t)))
 388               (if mm-name
 389                   (setq mm (if (string-equal mm-name "*") 0
 390                              (cdr (assoc-string
 391                                    mm-name
 392                                    (calendar-make-alist
 393                                     calendar-islamic-month-name-array) t)))))
 394               (mark-islamic-calendar-date-pattern mm dd yy)))))
 395       (setq d (cdr d)))))
 396
 397 (defun mark-islamic-calendar-date-pattern (month day year)
 398   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
 399 A value of 0 in any position is a wildcard."
 400   (save-excursion
 401     (set-buffer calendar-buffer)
 402     (if (and (/= 0 month) (/= 0 day))
 403         (if (/= 0 year)
 404             ;; Fully specified Islamic date.
 405             (let ((date (calendar-gregorian-from-absolute
 406                          (calendar-absolute-from-islamic
 407                           (list month day year)))))
 408               (if (calendar-date-is-visible-p date)
 409                   (mark-visible-calendar-date date)))
 410           ;; Month and day in any year--this taken from the holiday stuff.
 411           (let* ((islamic-date (calendar-islamic-from-absolute
 412                                 (calendar-absolute-from-gregorian
 413                                  (list displayed-month 15 displayed-year))))
 414                  (m (extract-calendar-month islamic-date))
 415                  (y (extract-calendar-year islamic-date))
 416                  (date))
 417             (if (< m 1)
 418                 nil;;   Islamic calendar doesn't apply.
 419               (increment-calendar-month m y (- 10 month))
 420               (if (> m 7);;  Islamic date might be visible
 421                   (let ((date (calendar-gregorian-from-absolute
 422                                (calendar-absolute-from-islamic
 423                                 (list month day y)))))
 424                     (if (calendar-date-is-visible-p date)
 425                         (mark-visible-calendar-date date)))))))
 426       ;; Not one of the simple cases--check all visible dates for match.
 427       ;; Actually, the following code takes care of ALL of the cases, but
 428       ;; it's much too slow to be used for the simple (common) cases.
 429       (let ((m displayed-month)
 430             (y displayed-year)
 431             (first-date)
 432             (last-date))
 433         (increment-calendar-month m y -1)
 434         (setq first-date
 435               (calendar-absolute-from-gregorian
 436                (list m 1 y)))
 437         (increment-calendar-month m y 2)
 438         (setq last-date
 439               (calendar-absolute-from-gregorian
 440                (list m (calendar-last-day-of-month m y) y)))
 441         (calendar-for-loop date from first-date to last-date do
 442           (let* ((i-date (calendar-islamic-from-absolute date))
 443                  (i-month (extract-calendar-month i-date))
 444                  (i-day (extract-calendar-day i-date))
 445                  (i-year (extract-calendar-year i-date)))
 446             (and (or (zerop month)
 447                      (= month i-month))
 448                  (or (zerop day)
 449                      (= day i-day))
 450                  (or (zerop year)
 451                      (= year i-year))
 452                  (mark-visible-calendar-date
 453                   (calendar-gregorian-from-absolute date)))))))))
 454
 455 (defun insert-islamic-diary-entry (arg)
 456   "Insert a diary entry.
 457 For the Islamic date corresponding to the date indicated by point.
 458 Prefix arg will make the entry nonmarking."
 459   (interactive "P")
 460   (let* ((calendar-month-name-array calendar-islamic-month-name-array))
 461     (make-diary-entry
 462      (concat
 463       islamic-diary-entry-symbol
 464       (calendar-date-string
 465        (calendar-islamic-from-absolute
 466         (calendar-absolute-from-gregorian
 467          (calendar-cursor-to-date t)))
 468        nil t))
 469      arg)))
 470
 471 (defun insert-monthly-islamic-diary-entry (arg)
 472   "Insert a monthly diary entry.
 473 For the day of the Islamic month 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 '(day " * ") '("* " day )))
 478          (calendar-month-name-array calendar-islamic-month-name-array))
 479     (make-diary-entry
 480      (concat
 481       islamic-diary-entry-symbol
 482       (calendar-date-string
 483        (calendar-islamic-from-absolute
 484         (calendar-absolute-from-gregorian
 485          (calendar-cursor-to-date t)))))
 486      arg)))
 487
 488 (defun insert-yearly-islamic-diary-entry (arg)
 489   "Insert an annual diary entry.
 490 For the day of the Islamic year corresponding to the date indicated by point.
 491 Prefix arg will make the entry nonmarking."
 492   (interactive "P")
 493   (let* ((calendar-date-display-form
 494           (if european-calendar-style
 495               '(day " " monthname)
 496             '(monthname " " day)))
 497          (calendar-month-name-array calendar-islamic-month-name-array))
 498     (make-diary-entry
 499      (concat
 500       islamic-diary-entry-symbol
 501       (calendar-date-string
 502        (calendar-islamic-from-absolute
 503         (calendar-absolute-from-gregorian
 504          (calendar-cursor-to-date t)))))
 505      arg)))
 506
 507 (provide 'cal-islam)
 508
 509 ;;; arch-tag: a951b6c1-6f47-48d5-bac3-1b505cd719f7
 510 ;;; cal-islam.el ends here