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