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