code.delx.au - gnu-emacs/blob - lisp/diary-lib.el

   1 ;;; diary.el --- diary functions.
   2
   3 ;; Copyright (C) 1989, 1990, 1992, 1993 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Keywords: calendar
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12 ;; accepts responsibility to anyone for the consequences of using it
  13 ;; or for whether it serves any particular purpose or works at all,
  14 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15 ;; License for full details.
  16
  17 ;; Everyone is granted permission to copy, modify and redistribute
  18 ;; GNU Emacs, but only under the conditions described in the
  19 ;; GNU Emacs General Public License.   A copy of this license is
  20 ;; supposed to have been given to you along with GNU Emacs so you
  21 ;; can know your rights and responsibilities.  It should be in a
  22 ;; file named COPYING.  Among other things, the copyright notice
  23 ;; and this notice must be preserved on all copies.
  24
  25 ;;; Commentary:
  26
  27 ;; This collection of functions implements the diary features as described
  28 ;; in calendar.el.
  29
  30 ;; Comments, corrections, and improvements should be sent to
  31 ;;  Edward M. Reingold               Department of Computer Science
  32 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  33 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  34 ;;                                   Urbana, Illinois 61801
  35
  36 ;;; Code:
  37
  38 (require 'calendar)
  39
  40 ;;;###autoload
  41 (defun diary (&optional arg)
  42   "Generate the diary window for ARG days starting with the current date.
  43 If no argument is provided, the number of days of diary entries is governed
  44 by the variable `number-of-diary-entries'.  This function is suitable for
  45 execution in a `.emacs' file."
  46   (interactive "P")
  47   (let ((d-file (substitute-in-file-name diary-file))
  48         (date (calendar-current-date)))
  49     (if (and d-file (file-exists-p d-file))
  50         (if (file-readable-p d-file)
  51             (list-diary-entries
  52              date
  53              (cond
  54               (arg (prefix-numeric-value arg))
  55               ((vectorp number-of-diary-entries)
  56                (aref number-of-diary-entries (calendar-day-of-week date)))
  57               (t number-of-diary-entries)))
  58         (error "Your diary file is not readable!"))
  59       (error "You don't have a diary file!"))))
  60
  61 (defun view-diary-entries (arg)
  62   "Prepare and display a buffer with diary entries.
  63 Searches the file named in `diary-file' for entries that
  64 match ARG days starting with the date indicated by the cursor position
  65 in the displayed three-month calendar."
  66   (interactive "p")
  67   (let ((d-file (substitute-in-file-name diary-file)))
  68     (if (and d-file (file-exists-p d-file))
  69         (if (file-readable-p d-file)
  70             (list-diary-entries (calendar-cursor-to-date t) arg)
  71           (error "Your diary file is not readable!"))
  72       (error "You don't have a diary file!"))))
  73
  74 (autoload 'check-calendar-holidays "holidays"
  75   "Check the list of holidays for any that occur on DATE.
  76 The value returned is a list of strings of relevant holiday descriptions.
  77 The holidays are those in the list `calendar-holidays'."
  78   t)
  79
  80
  81 (autoload 'calendar-holiday-list "holidays"
  82   "Form the list of holidays that occur on dates in the calendar window.
  83 The holidays are those in the list `calendar-holidays'."
  84   t)
  85
  86 (autoload 'diary-french-date "cal-french"
  87   "French calendar equivalent of date diary entry."
  88   t)
  89
  90 (autoload 'diary-mayan-date "cal-mayan"
  91   "Mayan calendar equivalent of date diary entry."
  92   t)
  93
  94 (autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
  95
  96 (autoload 'diary-sunrise-sunset "solar"
  97   "Local time of sunrise and sunset as a diary entry."
  98   t)
  99
 100 (autoload 'diary-sabbath-candles "solar"
 101   "Local time of candle lighting diary entry--applies if date is a Friday.
 102 No diary entry if there is no sunset on that date."
 103   t)
 104
 105 (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
 106   "The syntax table used when parsing dates in the diary file.
 107 It is the standard syntax table used in Fundamental mode, but with the
 108 syntax of `*' changed to be a word constituent.")
 109
 110 (modify-syntax-entry ?* "w" diary-syntax-table)
 111
 112 (defun list-diary-entries (date number)
 113   "Create and display a buffer containing the relevant lines in diary-file.
 114 The arguments are DATE and NUMBER; the entries selected are those
 115 for NUMBER days starting with date DATE.  The other entries are hidden
 116 using selective display.
 117
 118 Returns a list of all relevant diary entries found, if any, in order by date.
 119 The list entries have the form ((month day year) string).  If the variable
 120 `diary-list-include-blanks' is t, this list includes a dummy diary entry
 121 \(consisting of the empty string) for a date with no diary entries.
 122
 123 After the list is prepared, the hooks `nongregorian-diary-listing-hook',
 124 `list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
 125 These hooks have the following distinct roles:
 126
 127     `nongregorian-diary-listing-hook' can cull dates from the diary
 128         and each included file.  Usually used for Hebrew or Islamic
 129         diary entries in files.  Applied to *each* file.
 130
 131     `list-diary-entries-hook' adds or manipulates diary entries from
 132         external sources.  Used, for example, to include diary entries
 133         from other files or to sort the diary entries.  Invoked *once* only,
 134         before the display hook is run.
 135
 136     `diary-display-hook' does the actual display of information.  If this is
 137         nil, simple-diary-display will be used.  Use add-hook to set this to
 138         fancy-diary-display, if desired.  If you want no diary display, use
 139         add-hook to set this to ignore.
 140
 141     `diary-hook' is run last.  This can be used for an appointment
 142         notification function."
 143
 144   (if (< 0 number)
 145       (let* ((original-date date);; save for possible use in the hooks
 146              (old-diary-syntax-table)
 147              (diary-entries-list)
 148              (date-string (calendar-date-string date))
 149              (d-file (substitute-in-file-name diary-file)))
 150         (message "Preparing diary...")
 151         (save-excursion
 152           (let ((diary-buffer (get-file-buffer d-file)))
 153             (set-buffer (if diary-buffer
 154                             diary-buffer
 155                          (find-file-noselect d-file t))))
 156           (setq selective-display t)
 157           (setq selective-display-ellipses nil)
 158           (setq old-diary-syntax-table (syntax-table))
 159           (set-syntax-table diary-syntax-table)
 160           (unwind-protect
 161             (let ((buffer-read-only nil)
 162                   (diary-modified (buffer-modified-p))
 163                   (mark (regexp-quote diary-nonmarking-symbol)))
 164               (goto-char (1- (point-max)))
 165               (if (not (looking-at "\^M\\|\n"))
 166                   (progn
 167                     (forward-char 1)
 168                     (insert-string "\^M")))
 169               (goto-char (point-min))
 170               (if (not (looking-at "\^M\\|\n"))
 171                   (insert-string "\^M"))
 172               (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
 173               (calendar-for-loop i from 1 to number do
 174                  (let ((d diary-date-forms)
 175                        (month (extract-calendar-month date))
 176                        (day (extract-calendar-day date))
 177                        (year (extract-calendar-year date))
 178                        (entry-found (list-sexp-diary-entries date)))
 179                    (while d
 180                      (let*
 181                           ((date-form (if (equal (car (car d)) 'backup)
 182                                           (cdr (car d))
 183                                         (car d)))
 184                           (backup (equal (car (car d)) 'backup))
 185                           (dayname
 186                            (concat
 187                             (calendar-day-name date) "\\|"
 188                             (substring (calendar-day-name date) 0 3) ".?"))
 189                           (monthname
 190                            (concat
 191                             "\\*\\|"
 192                             (calendar-month-name month) "\\|"
 193                             (substring (calendar-month-name month) 0 3) ".?"))
 194                           (month (concat "\\*\\|0*" (int-to-string month)))
 195                           (day (concat "\\*\\|0*" (int-to-string day)))
 196                           (year
 197                            (concat
 198                             "\\*\\|0*" (int-to-string year)
 199                             (if abbreviated-calendar-year
 200                                 (concat "\\|" (int-to-string (% year 100)))
 201                               "")))
 202                           (regexp
 203                            (concat
 204                             "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
 205                             (mapconcat 'eval date-form "\\)\\(")
 206                             "\\)"))
 207                           (case-fold-search t))
 208                        (goto-char (point-min))
 209                        (while (re-search-forward regexp nil t)
 210                          (if backup (re-search-backward "\\<" nil t))
 211                          (if (and (or (char-equal (preceding-char) ?\^M)
 212                                       (char-equal (preceding-char) ?\n))
 213                                   (not (looking-at " \\|\^I")))
 214                              ;;  Diary entry that consists only of date.
 215                              (backward-char 1)
 216                            ;; Found a nonempty diary entry--make it visible and
 217                            ;; add it to the list.
 218                            (setq entry-found t)
 219                            (let ((entry-start (point))
 220                                  (date-start))
 221                              (re-search-backward "\^M\\|\n\\|\\`")
 222                              (setq date-start (point))
 223                              (re-search-forward "\^M\\|\n" nil t 2)
 224                              (while (looking-at " \\|\^I")
 225                                (re-search-forward "\^M\\|\n" nil t))
 226                              (backward-char 1)
 227                              (subst-char-in-region date-start
 228                                 (point) ?\^M ?\n t)
 229                              (add-to-diary-list
 230                                date (buffer-substring entry-start (point)))))))
 231                      (setq d (cdr d)))
 232                    (or entry-found
 233                        (not diary-list-include-blanks)
 234                        (setq diary-entries-list
 235                              (append diary-entries-list
 236                                      (list (list date "")))))
 237                    (setq date
 238                          (calendar-gregorian-from-absolute
 239                            (1+ (calendar-absolute-from-gregorian date))))
 240                    (setq entry-found nil)))
 241               (set-buffer-modified-p diary-modified))
 242           (set-syntax-table old-diary-syntax-table))
 243         (goto-char (point-min))
 244         (run-hooks 'nongregorian-diary-listing-hook
 245                    'list-diary-entries-hook)
 246         (if diary-display-hook
 247             (run-hooks 'diary-display-hook)
 248           (simple-diary-display))
 249         (run-hooks 'diary-hook)
 250         diary-entries-list))))
 251
 252 (defun include-other-diary-files ()
 253   "Include the diary entries from other diary files with those of diary-file.
 254 This function is suitable for use in `list-diary-entries-hook';
 255 it enables you to use shared diary files together with your own.
 256 The files included are specified in the diaryfile by lines of this form:
 257         #include \"filename\"
 258 This is recursive; that is, #include directives in diary files thus included
 259 are obeyed.  You can change the `#include' to some other string by
 260 changing the variable `diary-include-string'."
 261   (goto-char (point-min))
 262   (while (re-search-forward
 263           (concat
 264            "\\(\\`\\|\^M\\|\n\\)"
 265            (regexp-quote diary-include-string)
 266            " \"\\([^\"]*\\)\"")
 267           nil t)
 268     (let ((diary-file (substitute-in-file-name
 269                        (buffer-substring (match-beginning 2) (match-end 2))))
 270           (diary-list-include-blanks nil)
 271           (list-diary-entries-hook 'include-other-diary-files)
 272           (diary-display-hook 'ignore)
 273           (diary-hook nil))
 274       (if (file-exists-p diary-file)
 275           (if (file-readable-p diary-file)
 276               (unwind-protect
 277                   (setq diary-entries-list
 278                         (append diary-entries-list
 279                                 (list-diary-entries original-date number)))
 280                 (kill-buffer (get-file-buffer diary-file)))
 281             (beep)
 282             (message "Can't read included diary file %s" diary-file)
 283             (sleep-for 2))
 284         (beep)
 285         (message "Can't find included diary file %s" diary-file)
 286         (sleep-for 2))))
 287     (goto-char (point-min)))
 288
 289 (defun simple-diary-display ()
 290   "Display the diary buffer if there are any relevant entries or holidays."
 291   (let* ((holiday-list (if holidays-in-diary-buffer
 292                            (check-calendar-holidays original-date)))
 293          (msg (format "No diary entries for %s %s"
 294                       (concat date-string (if holiday-list ":" ""))
 295                       (mapconcat 'identity holiday-list "; "))))
 296     (if (or (not diary-entries-list)
 297             (and (not (cdr diary-entries-list))
 298                  (string-equal (car (cdr (car diary-entries-list))) "")))
 299         (if (<= (length msg) (frame-width))
 300             (message msg)
 301           (set-buffer (get-buffer-create holiday-buffer))
 302           (setq buffer-read-only nil)
 303           (calendar-set-mode-line date-string)
 304           (erase-buffer)
 305           (insert (mapconcat 'identity holiday-list "\n"))
 306           (goto-char (point-min))
 307           (set-buffer-modified-p nil)
 308           (setq buffer-read-only t)
 309           (display-buffer holiday-buffer)
 310           (message  "No diary entries for %s" date-string))
 311       (calendar-set-mode-line
 312        (concat "Diary for " date-string
 313                (if holiday-list ": " "")
 314                (mapconcat 'identity holiday-list "; ")))
 315       (display-buffer (get-file-buffer d-file))
 316       (message "Preparing diary...done"))))
 317
 318 (defun fancy-diary-display ()
 319   "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
 320 This function is provided for optional use as the `diary-display-hook'."
 321   (if (or (not diary-entries-list)
 322           (and (not (cdr diary-entries-list))
 323                (string-equal (car (cdr (car diary-entries-list))) "")))
 324       (let* ((holiday-list (if holidays-in-diary-buffer
 325                                (check-calendar-holidays original-date)))
 326              (msg (format "No diary entries for %s %s"
 327                           (concat date-string (if holiday-list ":" ""))
 328                           (mapconcat 'identity holiday-list "; "))))
 329         (if (<= (length msg) (frame-width))
 330             (message msg)
 331           (set-buffer (get-buffer-create holiday-buffer))
 332           (setq buffer-read-only nil)
 333           (calendar-set-mode-line date-string)
 334           (erase-buffer)
 335           (insert (mapconcat 'identity holiday-list "\n"))
 336           (goto-char (point-min))
 337           (set-buffer-modified-p nil)
 338           (setq buffer-read-only t)
 339           (display-buffer holiday-buffer)
 340           (message  "No diary entries for %s" date-string)))
 341     (save-excursion;; Turn off selective-display in the diary file's buffer.
 342       (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
 343       (let ((diary-modified (buffer-modified-p)))
 344         (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
 345         (setq selective-display nil)
 346         (kill-local-variable 'mode-line-format)
 347         (set-buffer-modified-p diary-modified)))
 348     (save-excursion;; Prepare the fancy diary buffer.
 349       (set-buffer (get-buffer-create fancy-diary-buffer))
 350       (setq buffer-read-only nil)
 351       (make-local-variable 'mode-line-format)
 352       (calendar-set-mode-line "Diary Entries")
 353       (erase-buffer)
 354       (let ((entry-list diary-entries-list)
 355             (holiday-list)
 356             (holiday-list-last-month 1)
 357             (holiday-list-last-year 1)
 358             (date (list 0 0 0)))
 359         (while entry-list
 360           (if (not (calendar-date-equal date (car (car entry-list))))
 361               (progn
 362                 (setq date (car (car entry-list)))
 363                 (and holidays-in-diary-buffer
 364                      (calendar-date-compare
 365                       (list (list holiday-list-last-month
 366                                   (calendar-last-day-of-month
 367                                    holiday-list-last-month
 368                                    holiday-list-last-year)
 369                                   holiday-list-last-year))
 370                       (list date))
 371                      ;; We need to get the holidays for the next 3 months.
 372                      (setq holiday-list-last-month
 373                            (extract-calendar-month date))
 374                      (setq holiday-list-last-year
 375                            (extract-calendar-year date))
 376                      (increment-calendar-month
 377                       holiday-list-last-month holiday-list-last-year 1)
 378                      (setq holiday-list
 379                            (let ((displayed-month holiday-list-last-month)
 380                                  (displayed-year holiday-list-last-year))
 381                              (calendar-holiday-list)))
 382                      (increment-calendar-month
 383                       holiday-list-last-month holiday-list-last-year 1))
 384                 (let* ((date-string (calendar-date-string date))
 385                        (date-holiday-list
 386                         (let ((h holiday-list)
 387                               (d))
 388                           ;; Make a list of all holidays for date.
 389                           (while h
 390                             (if (calendar-date-equal date (car (car h)))
 391                                 (setq d (append d (cdr (car h)))))
 392                             (setq h (cdr h)))
 393                           d)))
 394                   (insert (if (= (point) (point-min)) "" ?\n) date-string)
 395                   (if date-holiday-list (insert ":  "))
 396                   (let ((l (current-column)))
 397                     (insert (mapconcat 'identity date-holiday-list
 398                                        (concat "\n" (make-string l ? )))))
 399                   (let ((l (current-column)))
 400                     (insert ?\n (make-string l ?=) ?\n)))))
 401           (if (< 0 (length (car (cdr (car entry-list)))))
 402               (insert (car (cdr (car entry-list))) ?\n))
 403           (setq entry-list (cdr entry-list))))
 404       (set-buffer-modified-p nil)
 405       (goto-char (point-min))
 406       (setq buffer-read-only t)
 407       (display-buffer fancy-diary-buffer)
 408       (message "Preparing diary...done"))))
 409
 410 (defun print-diary-entries ()
 411   "Print a hard copy of the diary display.
 412
 413 If the simple diary display is being used, prepare a temp buffer with the
 414 visible lines of the diary buffer, add a heading line composed from the mode
 415 line, print the temp buffer, and destroy it.
 416
 417 If the fancy diary display is being used, just print the buffer.
 418
 419 The hooks given by the variable `print-diary-entries-hook' are called to do
 420 the actual printing."
 421   (interactive)
 422   (if (bufferp (get-buffer fancy-diary-buffer))
 423       (save-excursion
 424         (set-buffer (get-buffer fancy-diary-buffer))
 425         (run-hooks 'print-diary-entries-hook))
 426     (let ((diary-buffer
 427            (get-file-buffer (substitute-in-file-name diary-file))))
 428       (if diary-buffer
 429           (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
 430                 (heading))
 431             (save-excursion
 432               (set-buffer diary-buffer)
 433               (setq heading
 434                     (if (not (stringp mode-line-format))
 435                         "All Diary Entries"
 436                       (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
 437                       (substring mode-line-format
 438                                  (match-beginning 1) (match-end 1))))
 439               (copy-to-buffer temp-buffer (point-min) (point-max))
 440               (set-buffer temp-buffer)
 441               (while (re-search-forward "\^M.*$" nil t)
 442                 (replace-match ""))
 443               (goto-char (point-min))
 444               (insert heading "\n"
 445                       (make-string (length heading) ?=) "\n")
 446               (run-hooks 'print-diary-entries-hook)
 447               (kill-buffer temp-buffer)))
 448         (error "You don't have a diary buffer!")))))
 449
 450 (defun show-all-diary-entries ()
 451   "Show all of the diary entries in the diary file.
 452 This function gets rid of the selective display of the diary file so that
 453 all entries, not just some, are visible.  If there is no diary buffer, one
 454 is created."
 455   (interactive)
 456   (let ((d-file (substitute-in-file-name diary-file)))
 457     (if (and d-file (file-exists-p d-file))
 458         (if (file-readable-p d-file)
 459             (save-excursion
 460               (let ((diary-buffer (get-file-buffer d-file)))
 461                 (set-buffer (if diary-buffer
 462                                 diary-buffer
 463                               (find-file-noselect d-file t)))
 464                 (let ((buffer-read-only nil)
 465                       (diary-modified (buffer-modified-p)))
 466                   (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
 467                   (setq selective-display nil)
 468                   (make-local-variable 'mode-line-format)
 469                   (setq mode-line-format default-mode-line-format)
 470                   (display-buffer (current-buffer))
 471                   (set-buffer-modified-p diary-modified))))
 472           (error "Your diary file is not readable!"))
 473       (error "You don't have a diary file!"))))
 474
 475 (defun diary-name-pattern (string-array &optional fullname)
 476   "Convert an STRING-ARRAY, an array of strings to a pattern.
 477 The pattern will match any of the strings, either entirely or abbreviated
 478 to three characters.  An abbreviated form will match with or without a period;
 479 If the optional FULLNAME is t, abbreviations will not match, just the full
 480 name."
 481   (let ((pattern ""))
 482     (calendar-for-loop i from 0 to (1- (length string-array)) do
 483       (setq pattern
 484             (concat
 485              pattern
 486              (if (string-equal pattern "") "" "\\|")
 487              (aref string-array i)
 488              (if fullname
 489                  ""
 490                (concat
 491                 "\\|"
 492                 (substring (aref string-array i) 0 3) ".?")))))
 493     pattern))
 494
 495 (defun mark-diary-entries ()
 496   "Mark days in the calendar window that have diary entries.
 497 Each entry in the diary file visible in the calendar window is marked.
 498 After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
 499 `mark-diary-entries-hook' are run."
 500   (interactive)
 501   (setq mark-diary-entries-in-calendar t)
 502   (let ((d-file (substitute-in-file-name diary-file)))
 503     (if (and d-file (file-exists-p d-file))
 504         (if (file-readable-p d-file)
 505             (save-excursion
 506               (message "Marking diary entries...")
 507               (set-buffer (find-file-noselect d-file t))
 508               (let ((d diary-date-forms)
 509                     (old-diary-syntax-table))
 510                 (setq old-diary-syntax-table (syntax-table))
 511                 (set-syntax-table diary-syntax-table)
 512                 (while d
 513                   (let*
 514                       ((date-form (if (equal (car (car d)) 'backup)
 515                                       (cdr (car d))
 516                                     (car d)));; ignore 'backup directive
 517                        (dayname (diary-name-pattern calendar-day-name-array))
 518                        (monthname
 519                         (concat
 520                          (diary-name-pattern calendar-month-name-array)
 521                          "\\|\\*"))
 522                        (month "[0-9]+\\|\\*")
 523                        (day "[0-9]+\\|\\*")
 524                        (year "[0-9]+\\|\\*")
 525                        (l (length date-form))
 526                        (d-name-pos (- l (length (memq 'dayname date-form))))
 527                        (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 528                        (m-name-pos (- l (length (memq 'monthname date-form))))
 529                        (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 530                        (d-pos (- l (length (memq 'day date-form))))
 531                        (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 532                        (m-pos (- l (length (memq 'month date-form))))
 533                        (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 534                        (y-pos (- l (length (memq 'year date-form))))
 535                        (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 536                        (regexp
 537                         (concat
 538                          "\\(\\`\\|\^M\\|\n\\)\\("
 539                          (mapconcat 'eval date-form "\\)\\(")
 540                          "\\)"))
 541                        (case-fold-search t))
 542                     (goto-char (point-min))
 543                     (while (re-search-forward regexp nil t)
 544                       (let* ((dd-name
 545                               (if d-name-pos
 546                                   (buffer-substring
 547                                    (match-beginning d-name-pos)
 548                                    (match-end d-name-pos))))
 549                              (mm-name
 550                               (if m-name-pos
 551                                   (buffer-substring
 552                                    (match-beginning m-name-pos)
 553                                    (match-end m-name-pos))))
 554                              (mm (string-to-int
 555                                   (if m-pos
 556                                       (buffer-substring
 557                                        (match-beginning m-pos)
 558                                        (match-end m-pos))
 559                                     "")))
 560                              (dd (string-to-int
 561                                   (if d-pos
 562                                       (buffer-substring
 563                                        (match-beginning d-pos)
 564                                        (match-end d-pos))
 565                                     "")))
 566                              (y-str (if y-pos
 567                                         (buffer-substring
 568                                          (match-beginning y-pos)
 569                                          (match-end y-pos))))
 570                              (yy (if (not y-str)
 571                                      0
 572                                    (if (and (= (length y-str) 2)
 573                                             abbreviated-calendar-year)
 574                                        (let* ((current-y
 575                                                (extract-calendar-year
 576                                                 (calendar-current-date)))
 577                                               (y (+ (string-to-int y-str)
 578                                                     (* 100
 579                                                        (/ current-y 100)))))
 580                                          (if (> (- y current-y) 50)
 581                                              (- y 100)
 582                                            (if (> (- current-y y) 50)
 583                                                (+ y 100)
 584                                              y)))
 585                                      (string-to-int y-str)))))
 586                         (if dd-name
 587                             (mark-calendar-days-named
 588                              (cdr (assoc (capitalize (substring dd-name 0 3))
 589                                          (calendar-make-alist
 590                                           calendar-day-name-array
 591                                           0
 592                                           '(lambda (x) (substring x 0 3))))))
 593                           (if mm-name
 594                               (if (string-equal mm-name "*")
 595                                   (setq mm 0)
 596                                 (setq mm
 597                                       (cdr (assoc
 598                                             (capitalize
 599                                              (substring mm-name 0 3))
 600                                             (calendar-make-alist
 601                                              calendar-month-name-array
 602                                              1
 603                                              '(lambda (x) (substring x 0 3)))
 604                                             )))))
 605                           (mark-calendar-date-pattern mm dd yy))))
 606                     (setq d (cdr d))))
 607                 (mark-sexp-diary-entries)
 608                 (run-hooks 'nongregorian-diary-marking-hook
 609                            'mark-diary-entries-hook)
 610                 (set-syntax-table old-diary-syntax-table)
 611                 (message "Marking diary entries...done")))
 612           (error "Your diary file is not readable!"))
 613       (error "You don't have a diary file!"))))
 614
 615 (defun mark-sexp-diary-entries ()
 616   "Mark days in the calendar window that have sexp diary entries.
 617 Each entry in the diary file (or included files) visible in the calendar window
 618 is marked.  See the documentation for the function `list-sexp-diary-entries'."
 619   (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
 620          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "("))
 621          (m)
 622          (y)
 623          (first-date)
 624          (last-date))
 625     (save-excursion
 626       (set-buffer calendar-buffer)
 627       (setq m displayed-month)
 628       (setq y displayed-year))
 629     (increment-calendar-month m y -1)
 630     (setq first-date
 631           (calendar-absolute-from-gregorian (list m 1 y)))
 632     (increment-calendar-month m y 2)
 633     (setq last-date
 634           (calendar-absolute-from-gregorian
 635            (list m (calendar-last-day-of-month m y) y)))
 636     (goto-char (point-min))
 637     (while (re-search-forward s-entry nil t)
 638       (backward-char 1)
 639       (let ((sexp-start (point))
 640             (sexp)
 641             (entry)
 642             (entry-start)
 643             (line-start))
 644         (forward-sexp)
 645         (setq sexp (buffer-substring sexp-start (point)))
 646         (save-excursion
 647           (re-search-backward "\^M\\|\n\\|\\`")
 648           (setq line-start (point)))
 649         (forward-char 1)
 650         (if (and (or (char-equal (preceding-char) ?\^M)
 651                      (char-equal (preceding-char) ?\n))
 652                  (not (looking-at " \\|\^I")))
 653             (progn;; Diary entry consists only of the sexp
 654               (backward-char 1)
 655               (setq entry ""))
 656           (setq entry-start (point))
 657           (re-search-forward "\^M\\|\n" nil t)
 658           (while (looking-at " \\|\^I")
 659             (re-search-forward "\^M\\|\n" nil t))
 660           (backward-char 1)
 661           (setq entry (buffer-substring entry-start (point)))
 662           (while (string-match "[\^M]" entry)
 663             (aset entry (match-beginning 0) ?\n )))
 664         (calendar-for-loop date from first-date to last-date do
 665           (if (diary-sexp-entry sexp entry
 666                                 (calendar-gregorian-from-absolute date))
 667               (mark-visible-calendar-date
 668                (calendar-gregorian-from-absolute date))))))))
 669
 670 (defun mark-included-diary-files ()
 671   "Mark the diary entries from other diary files with those of the diary file.
 672 This function is suitable for use as the `mark-diary-entries-hook'; it enables
 673 you to use shared diary files together with your own.  The files included are
 674 specified in the diary-file by lines of this form:
 675         #include \"filename\"
 676 This is recursive; that is, #include directives in diary files thus included
 677 are obeyed.  You can change the `#include' to some other string by
 678 changing the variable `diary-include-string'."
 679   (goto-char (point-min))
 680   (while (re-search-forward
 681           (concat
 682            "\\(\\`\\|\^M\\|\n\\)"
 683            (regexp-quote diary-include-string)
 684            " \"\\([^\"]*\\)\"")
 685           nil t)
 686     (let ((diary-file (substitute-in-file-name
 687                        (buffer-substring (match-beginning 2) (match-end 2))))
 688           (mark-diary-entries-hook 'mark-included-diary-files))
 689       (if (file-exists-p diary-file)
 690           (if (file-readable-p diary-file)
 691               (progn
 692                 (mark-diary-entries)
 693                 (kill-buffer (get-file-buffer diary-file)))
 694             (beep)
 695             (message "Can't read included diary file %s" diary-file)
 696             (sleep-for 2))
 697         (beep)
 698         (message "Can't find included diary file %s" diary-file)
 699         (sleep-for 2))))
 700   (goto-char (point-min)))
 701
 702 (defun mark-calendar-days-named (dayname)
 703   "Mark all dates in the calendar window that are day DAYNAME of the week.
 704 0 means all Sundays, 1 means all Mondays, and so on."
 705   (save-excursion
 706     (set-buffer calendar-buffer)
 707     (let ((prev-month displayed-month)
 708           (prev-year displayed-year)
 709           (succ-month displayed-month)
 710           (succ-year displayed-year)
 711           (last-day)
 712           (day))
 713       (increment-calendar-month succ-month succ-year 1)
 714       (increment-calendar-month prev-month prev-year -1)
 715       (setq day (calendar-absolute-from-gregorian
 716                  (calendar-nth-named-day 1 dayname prev-month prev-year)))
 717       (setq last-day (calendar-absolute-from-gregorian
 718                  (calendar-nth-named-day -1 dayname succ-month succ-year)))
 719       (while (<= day last-day)
 720         (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
 721         (setq day (+ day 7))))))
 722
 723 (defun mark-calendar-date-pattern (month day year)
 724   "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
 725 A value of 0 in any position is a wildcard."
 726   (save-excursion
 727     (set-buffer calendar-buffer)
 728     (let ((m displayed-month)
 729           (y displayed-year))
 730       (increment-calendar-month m y -1)
 731       (calendar-for-loop i from 0 to 2 do
 732           (mark-calendar-month m y month day year)
 733           (increment-calendar-month m y 1)))))
 734
 735 (defun mark-calendar-month (month year p-month p-day p-year)
 736   "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
 737 A value of 0 in any position of the pattern is a wildcard."
 738   (if (or (and (= month p-month)
 739                (or (= p-year 0) (= year p-year)))
 740           (and (= p-month 0)
 741                (or (= p-year 0) (= year p-year))))
 742       (if (= p-day 0)
 743           (calendar-for-loop
 744               i from 1 to (calendar-last-day-of-month month year) do
 745             (mark-visible-calendar-date (list month i year)))
 746         (mark-visible-calendar-date (list month p-day year)))))
 747
 748 (defun sort-diary-entries ()
 749   "Sort the list of diary entries by time of day."
 750   (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
 751
 752 (defun diary-entry-compare (e1 e2)
 753   "Returns t if E1 is earlier than E2."
 754   (or (calendar-date-compare e1 e2)
 755       (and (calendar-date-equal (car e1) (car e2))
 756            (< (diary-entry-time (car (cdr e1)))
 757               (diary-entry-time (car (cdr e2)))))))
 758
 759 (defun diary-entry-time (s)
 760   "Time at the beginning of the string S in a military-style integer.
 761 For example, returns 1325 for 1:25pm.  Returns -9999 if no time is recognized.
 762 The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
 763 and XX:XXam or XX:XXpm."
 764   (cond ((string-match;; Military time
 765           "^ *\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
 766          (+ (* 100 (string-to-int
 767                     (substring s (match-beginning 1) (match-end 1))))
 768             (string-to-int (substring s (match-beginning 2) (match-end 2)))))
 769         ((string-match;; Hour only  XXam or XXpm
 770           "^ *\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
 771          (+ (* 100 (% (string-to-int
 772                          (substring s (match-beginning 1) (match-end 1)))
 773                         12))
 774             (if (string-equal "a"
 775                               (substring s (match-beginning 2) (match-end 2)))
 776                 0 1200)))
 777         ((string-match;; Hour and minute  XX:XXam or XX:XXpm
 778           "^ *\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
 779          (+ (* 100 (% (string-to-int
 780                          (substring s (match-beginning 1) (match-end 1)))
 781                         12))
 782             (string-to-int (substring s (match-beginning 2) (match-end 2)))
 783             (if (string-equal "a"
 784                               (substring s (match-beginning 3) (match-end 3)))
 785                 0 1200)))
 786         (t -9999)));; Unrecognizable
 787
 788 (defun list-hebrew-diary-entries ()
 789   "Add any Hebrew date entries from the diary file to `diary-entries-list'.
 790 Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol'
 791 (normally an `H').  The same diary date forms govern the style of the Hebrew
 792 calendar entries, except that the Hebrew month names must be spelled in full.
 793 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
 794 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
 795 common Hebrew year.  If a Hebrew date diary entry begins with a
 796 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
 797 not be marked in the calendar.  This function is provided for use with the
 798 `nongregorian-diary-listing-hook'."
 799   (if (< 0 number)
 800       (let ((buffer-read-only nil)
 801             (diary-modified (buffer-modified-p))
 802             (gdate original-date)
 803             (mark (regexp-quote diary-nonmarking-symbol)))
 804         (calendar-for-loop i from 1 to number do
 805            (let* ((d diary-date-forms)
 806                   (hdate (calendar-hebrew-from-absolute
 807                           (calendar-absolute-from-gregorian gdate)))
 808                   (month (extract-calendar-month hdate))
 809                   (day (extract-calendar-day hdate))
 810                   (year (extract-calendar-year hdate)))
 811              (while d
 812                (let*
 813                    ((date-form (if (equal (car (car d)) 'backup)
 814                                    (cdr (car d))
 815                                  (car d)))
 816                     (backup (equal (car (car d)) 'backup))
 817                     (dayname
 818                      (concat
 819                       (calendar-day-name gdate) "\\|"
 820                       (substring (calendar-day-name gdate) 0 3) ".?"))
 821                     (calendar-month-name-array
 822                      calendar-hebrew-month-name-array-leap-year)
 823                     (monthname
 824                      (concat
 825                       "\\*\\|"
 826                       (calendar-month-name month)))
 827                     (month (concat "\\*\\|0*" (int-to-string month)))
 828                     (day (concat "\\*\\|0*" (int-to-string day)))
 829                     (year
 830                      (concat
 831                       "\\*\\|0*" (int-to-string year)
 832                       (if abbreviated-calendar-year
 833                           (concat "\\|" (int-to-string (% year 100)))
 834                         "")))
 835                     (regexp
 836                      (concat
 837                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
 838                       (regexp-quote hebrew-diary-entry-symbol)
 839                       "\\("
 840                       (mapconcat 'eval date-form "\\)\\(")
 841                       "\\)"))
 842                     (case-fold-search t))
 843                  (goto-char (point-min))
 844                  (while (re-search-forward regexp nil t)
 845                    (if backup (re-search-backward "\\<" nil t))
 846                    (if (and (or (char-equal (preceding-char) ?\^M)
 847                                 (char-equal (preceding-char) ?\n))
 848                             (not (looking-at " \\|\^I")))
 849                        ;;  Diary entry that consists only of date.
 850                        (backward-char 1)
 851                      ;;  Found a nonempty diary entry--make it visible and
 852                      ;;  add it to the list.
 853                      (let ((entry-start (point))
 854                            (date-start))
 855                        (re-search-backward "\^M\\|\n\\|\\`")
 856                        (setq date-start (point))
 857                        (re-search-forward "\^M\\|\n" nil t 2)
 858                        (while (looking-at " \\|\^I")
 859                          (re-search-forward "\^M\\|\n" nil t))
 860                        (backward-char 1)
 861                        (subst-char-in-region date-start (point) ?\^M ?\n t)
 862                        (add-to-diary-list
 863                          gdate (buffer-substring entry-start (point)))))))
 864                (setq d (cdr d))))
 865            (setq gdate
 866                  (calendar-gregorian-from-absolute
 867                   (1+ (calendar-absolute-from-gregorian gdate)))))
 868            (set-buffer-modified-p diary-modified))
 869         (goto-char (point-min))))
 870
 871 (defun mark-hebrew-diary-entries ()
 872   "Mark days in the calendar window that have Hebrew date diary entries.
 873 Each entry in diary-file (or included files) visible in the calendar window
 874 is marked.  Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
 875 (normally an `H').  The same diary-date-forms govern the style of the Hebrew
 876 calendar entries, except that the Hebrew month names must be spelled in full.
 877 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
 878 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
 879 common Hebrew year.  Hebrew date diary entries that begin with a
 880 diary-nonmarking symbol will not be marked in the calendar.  This function
 881 is provided for use as part of the nongregorian-diary-marking-hook."
 882   (let ((d diary-date-forms))
 883     (while d
 884       (let*
 885           ((date-form (if (equal (car (car d)) 'backup)
 886                           (cdr (car d))
 887                         (car d)));; ignore 'backup directive
 888            (dayname (diary-name-pattern calendar-day-name-array))
 889            (monthname
 890             (concat
 891              (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
 892              "\\|\\*"))
 893            (month "[0-9]+\\|\\*")
 894            (day "[0-9]+\\|\\*")
 895            (year "[0-9]+\\|\\*")
 896            (l (length date-form))
 897            (d-name-pos (- l (length (memq 'dayname date-form))))
 898            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
 899            (m-name-pos (- l (length (memq 'monthname date-form))))
 900            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
 901            (d-pos (- l (length (memq 'day date-form))))
 902            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
 903            (m-pos (- l (length (memq 'month date-form))))
 904            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
 905            (y-pos (- l (length (memq 'year date-form))))
 906            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
 907            (regexp
 908             (concat
 909              "\\(\\`\\|\^M\\|\n\\)"
 910              (regexp-quote hebrew-diary-entry-symbol)
 911              "\\("
 912              (mapconcat 'eval date-form "\\)\\(")
 913              "\\)"))
 914            (case-fold-search t))
 915         (goto-char (point-min))
 916         (while (re-search-forward regexp nil t)
 917           (let* ((dd-name
 918                   (if d-name-pos
 919                       (buffer-substring
 920                        (match-beginning d-name-pos)
 921                        (match-end d-name-pos))))
 922                  (mm-name
 923                   (if m-name-pos
 924                       (buffer-substring
 925                        (match-beginning m-name-pos)
 926                        (match-end m-name-pos))))
 927                  (mm (string-to-int
 928                       (if m-pos
 929                           (buffer-substring
 930                            (match-beginning m-pos)
 931                            (match-end m-pos))
 932                         "")))
 933                  (dd (string-to-int
 934                       (if d-pos
 935                           (buffer-substring
 936                            (match-beginning d-pos)
 937                            (match-end d-pos))
 938                         "")))
 939                  (y-str (if y-pos
 940                             (buffer-substring
 941                              (match-beginning y-pos)
 942                              (match-end y-pos))))
 943                  (yy (if (not y-str)
 944                          0
 945                        (if (and (= (length y-str) 2)
 946                                 abbreviated-calendar-year)
 947                            (let* ((current-y
 948                                    (extract-calendar-year
 949                                     (calendar-hebrew-from-absolute
 950                                      (calendar-absolute-from-gregorian
 951                                       (calendar-current-date)))))
 952                                   (y (+ (string-to-int y-str)
 953                                         (* 100 (/ current-y 100)))))
 954                              (if (> (- y current-y) 50)
 955                                  (- y 100)
 956                                (if (> (- current-y y) 50)
 957                                    (+ y 100)
 958                                  y)))
 959                          (string-to-int y-str)))))
 960             (if dd-name
 961                 (mark-calendar-days-named
 962                  (cdr (assoc (capitalize (substring dd-name 0 3))
 963                              (calendar-make-alist
 964                                calendar-day-name-array
 965                                0
 966                               '(lambda (x) (substring x 0 3))))))
 967               (if mm-name
 968                   (if (string-equal mm-name "*")
 969                       (setq mm 0)
 970                     (setq
 971                       mm
 972                       (cdr
 973                         (assoc
 974                           (capitalize mm-name)
 975                             (calendar-make-alist
 976                                calendar-hebrew-month-name-array-leap-year))))))
 977               (mark-hebrew-calendar-date-pattern mm dd yy)))))
 978       (setq d (cdr d)))))
 979
 980 (defun mark-hebrew-calendar-date-pattern (month day year)
 981   "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
 982 A value of 0 in any position is a wildcard."
 983   (save-excursion
 984     (set-buffer calendar-buffer)
 985     (if (and (/= 0 month) (/= 0 day))
 986         (if (/= 0 year)
 987             ;; Fully specified Hebrew date.
 988             (let ((date (calendar-gregorian-from-absolute
 989                          (calendar-absolute-from-hebrew
 990                           (list month day year)))))
 991               (if (calendar-date-is-visible-p date)
 992                   (mark-visible-calendar-date date)))
 993           ;; Month and day in any year--this taken from the holiday stuff.
 994           (if (memq displayed-month;;  This test is only to speed things up a
 995                     (list          ;;  bit; it works fine without the test too.
 996                      (if (< 11 month) (- month 11) (+ month 1))
 997                      (if (< 10 month) (- month 10) (+ month 2))
 998                      (if (<  9 month) (- month  9) (+ month 3))
 999                      (if (<  8 month) (- month  8) (+ month 4))
1000                      (if (<  7 month) (- month  7) (+ month 5))))
1001               (let ((m1 displayed-month)
1002                     (y1 displayed-year)
1003                     (m2 displayed-month)
1004                     (y2 displayed-year)
1005                     (year))
1006                 (increment-calendar-month m1 y1 -1)
1007                 (increment-calendar-month m2 y2 1)
1008                 (let* ((start-date (calendar-absolute-from-gregorian
1009                                     (list m1 1 y1)))
1010                        (end-date (calendar-absolute-from-gregorian
1011                                   (list m2
1012                                         (calendar-last-day-of-month m2 y2)
1013                                         y2)))
1014                        (hebrew-start
1015                         (calendar-hebrew-from-absolute start-date))
1016                        (hebrew-end (calendar-hebrew-from-absolute end-date))
1017                        (hebrew-y1 (extract-calendar-year hebrew-start))
1018                        (hebrew-y2 (extract-calendar-year hebrew-end)))
1019                   (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
1020                   (let ((date (calendar-gregorian-from-absolute
1021                                (calendar-absolute-from-hebrew
1022                                 (list month day year)))))
1023                     (if (calendar-date-is-visible-p date)
1024                         (mark-visible-calendar-date date)))))))
1025       ;; Not one of the simple cases--check all visible dates for match.
1026       ;; Actually, the following code takes care of ALL of the cases, but
1027       ;; it's much too slow to be used for the simple (common) cases.
1028       (let ((m displayed-month)
1029             (y displayed-year)
1030             (first-date)
1031             (last-date))
1032         (increment-calendar-month m y -1)
1033         (setq first-date
1034               (calendar-absolute-from-gregorian
1035                (list m 1 y)))
1036         (increment-calendar-month m y 2)
1037         (setq last-date
1038               (calendar-absolute-from-gregorian
1039                (list m (calendar-last-day-of-month m y) y)))
1040         (calendar-for-loop date from first-date to last-date do
1041           (let* ((h-date (calendar-hebrew-from-absolute date))
1042                  (h-month (extract-calendar-month h-date))
1043                  (h-day (extract-calendar-day h-date))
1044                  (h-year (extract-calendar-year h-date)))
1045             (and (or (zerop month)
1046                      (= month h-month))
1047                  (or (zerop day)
1048                      (= day h-day))
1049                  (or (zerop year)
1050                      (= year h-year))
1051                  (mark-visible-calendar-date
1052                   (calendar-gregorian-from-absolute date)))))))))
1053
1054 (defun list-sexp-diary-entries (date)
1055   "Add sexp entries for DATE from the diary file to `diary-entries-list'.
1056 Also, Make them visible in the diary file.  Returns t if any entries were
1057 found.
1058
1059 Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
1060 `%%').  The form of a sexp diary entry is
1061
1062                   %%(SEXP) ENTRY
1063
1064 Both ENTRY and DATE are globally available when the SEXP is evaluated.  If the
1065 SEXP yields the value nil, the diary entry does not apply.  If it yields a
1066 non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
1067 string, that string will be the diary entry in the fancy diary display.
1068
1069 For example, the following diary entry will apply to the 21st of the month
1070 if it is a weekday and the Friday before if the 21st is on a weekend:
1071
1072       &%%(let ((dayname (calendar-day-of-week date))
1073                (day (extract-calendar-day date)))
1074            (or
1075              (and (= day 21) (memq dayname '(1 2 3 4 5)))
1076              (and (memq day '(19 20)) (= dayname 5)))
1077          ) UIUC pay checks deposited
1078
1079 A number of built-in functions are available for this type of diary entry:
1080
1081       %%(diary-float MONTH DAYNAME N) text
1082                   Entry will appear on the Nth DAYNAME of MONTH.
1083                   (DAYNAME=0 means Sunday, 1 means Monday, and so on;
1084                   if N is negative it counts backward from the end of
1085                   the month.  MONTH can be a list of months, a single
1086                   month, or t to specify all months.
1087
1088       %%(diary-block M1 D1 Y1 M2 D2 Y2) text
1089                   Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
1090                   inclusive.  (If `european-calendar-style' is t, the
1091                   order of the parameters should be changed to D1, M1, Y1,
1092                   D2, M2, Y2.)
1093
1094       %%(diary-anniversary MONTH DAY YEAR) text
1095                   Entry will appear on anniversary dates of MONTH DAY, YEAR.
1096                   (If `european-calendar-style' is t, the order of the
1097                   parameters should be changed to DAY, MONTH, YEAR.)  Text
1098                   can contain %d or %d%s; %d will be replaced by the number
1099                   of years since the MONTH DAY, YEAR and %s will be replaced
1100                   by the ordinal ending of that number (that is, `st', `nd',
1101                   `rd' or `th', as appropriate.  The anniversary of February
1102                   29 is considered to be March 1 in a non-leap year.
1103
1104       %%(diary-cyclic N MONTH DAY YEAR) text
1105                   Entry will appear every N days, starting MONTH DAY, YEAR.
1106                   (If `european-calendar-style' is t, the order of the
1107                   parameters should be changed to N, DAY, MONTH, YEAR.)  Text
1108                   can contain %d or %d%s; %d will be replaced by the number
1109                   of repetitions since the MONTH DAY, YEAR and %s will
1110                   be replaced by the ordinal ending of that number (that is,
1111                   `st', `nd', `rd' or `th', as appropriate.
1112
1113       %%(diary-day-of-year)
1114                   Diary entries giving the day of the year and the number of
1115                   days remaining in the year will be made every day.  Note
1116                   that since there is no text, it makes sense only if the
1117                   fancy diary display is used.
1118
1119       %%(diary-iso-date)
1120                   Diary entries giving the corresponding ISO commercial date
1121                   will be made every day.  Note that since there is no text,
1122                   it makes sense only if the fancy diary display is used.
1123
1124       %%(diary-french-date)
1125                   Diary entries giving the corresponding French Revolutionary
1126                   date will be made every day.  Note that since there is no
1127                   text, it makes sense only if the fancy diary display is used.
1128
1129       %%(diary-islamic-date)
1130                   Diary entries giving the corresponding Islamic date will be
1131                   made every day.  Note that since there is no text, it
1132                   makes sense only if the fancy diary display is used.
1133
1134       %%(diary-hebrew-date)
1135                   Diary entries giving the corresponding Hebrew date will be
1136                   made every day.  Note that since there is no text, it
1137                   makes sense only if the fancy diary display is used.
1138
1139       %%(diary-astro-day-number) Diary entries giving the corresponding
1140                   astronomical (Julian) day number will be made every day.
1141                   Note that since there is no text, it makes sense only if the
1142                   fancy diary display is used.
1143
1144       %%(diary-julian-date) Diary entries giving the corresponding
1145                  Julian date will be made every day.  Note that since
1146                  there is no text, it makes sense only if the fancy diary
1147                  display is used.
1148
1149       %%(diary-sunrise-sunset)
1150                   Diary entries giving the local times of sunrise and sunset
1151                   will be made every day.  Note that since there is no text,
1152                   it makes sense only if the fancy diary display is used.
1153                   Floating point required.
1154
1155       %%(diary-phases-of-moon)
1156                   Diary entries giving the times of the phases of the moon
1157                   will be when appropriate.  Note that since there is no text,
1158                   it makes sense only if the fancy diary display is used.
1159                   Floating point required.
1160
1161       %%(diary-yahrzeit MONTH DAY YEAR) text
1162                   Text is assumed to be the name of the person; the date is
1163                   the date of death on the *civil* calendar.  The diary entry
1164                   will appear on the proper Hebrew-date anniversary and on the
1165                   day before.  (If `european-calendar-style' is t, the order
1166                   of the parameters should be changed to DAY, MONTH, YEAR.)
1167
1168       %%(diary-rosh-hodesh)
1169                   Diary entries will be made on the dates of Rosh Hodesh on
1170                   the Hebrew calendar.  Note that since there is no text, it
1171                   makes sense only if the fancy diary display is used.
1172
1173       %%(diary-parasha)
1174                   Diary entries giving the weekly parasha will be made on
1175                   every Saturday.  Note that since there is no text, it
1176                   makes sense only if the fancy diary display is used.
1177
1178       %%(diary-omer)
1179                   Diary entries giving the omer count will be made every day
1180                   from Passover to Shavuoth.  Note that since there is no text,
1181                   it makes sense only if the fancy diary display is used.
1182
1183 Marking these entries is *extremely* time consuming, so these entries are
1184 best if they are nonmarking."
1185   (let* ((mark (regexp-quote diary-nonmarking-symbol))
1186          (sexp-mark (regexp-quote sexp-diary-entry-symbol))
1187          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
1188          (entry-found))
1189     (goto-char (point-min))
1190     (while (re-search-forward s-entry nil t)
1191       (backward-char 1)
1192       (let ((sexp-start (point))
1193             (sexp)
1194             (entry)
1195             (entry-start)
1196             (line-start))
1197         (forward-sexp)
1198         (setq sexp (buffer-substring sexp-start (point)))
1199         (save-excursion
1200           (re-search-backward "\^M\\|\n\\|\\`")
1201           (setq line-start (point)))
1202         (forward-char 1)
1203         (if (and (or (char-equal (preceding-char) ?\^M)
1204                      (char-equal (preceding-char) ?\n))
1205                  (not (looking-at " \\|\^I")))
1206             (progn;; Diary entry consists only of the sexp
1207               (backward-char 1)
1208               (setq entry ""))
1209           (setq entry-start (point))
1210           (re-search-forward "\^M\\|\n" nil t)
1211           (while (looking-at " \\|\^I")
1212             (re-search-forward "\^M\\|\n" nil t))
1213           (backward-char 1)
1214           (setq entry (buffer-substring entry-start (point)))
1215           (while (string-match "[\^M]" entry)
1216             (aset entry (match-beginning 0) ?\n )))
1217         (let ((diary-entry (diary-sexp-entry sexp entry date)))
1218           (if diary-entry
1219               (subst-char-in-region line-start (point) ?\^M ?\n t))
1220           (add-to-diary-list date diary-entry)
1221           (setq entry-found (or entry-found diary-entry)))))
1222     entry-found))
1223
1224 (defun diary-sexp-entry (sexp entry date)
1225   "Process a SEXP diary ENTRY for DATE."
1226   (let ((result (if calendar-debug-sexp
1227                   (let ((stack-trace-on-error t))
1228                     (eval (car (read-from-string sexp))))
1229                   (condition-case nil
1230                       (eval (car (read-from-string sexp)))
1231                     (error
1232                      (beep)
1233                      (message "Bad sexp at line %d in %s: %s"
1234                               (save-excursion
1235                                 (save-restriction
1236                                   (narrow-to-region 1 (point))
1237                                   (goto-char (point-min))
1238                                   (let ((lines 1))
1239                                     (while (re-search-forward "\n\\|\^M" nil t)
1240                                       (setq lines (1+ lines)))
1241                                     lines)))
1242                               diary-file sexp)
1243                      (sleep-for 2))))))
1244     (if (stringp result)
1245         result
1246       (if result
1247           entry
1248         nil))))
1249
1250 (defun diary-block (m1 d1 y1 m2 d2 y2)
1251   "Block diary entry.
1252 Entry applies if date is between two dates.  Order of the parameters is
1253 M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
1254 D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
1255   (let ((date1 (calendar-absolute-from-gregorian
1256                 (if european-calendar-style
1257                     (list d1 m1 y1)
1258                   (list m1 d1 y1))))
1259         (date2 (calendar-absolute-from-gregorian
1260                 (if european-calendar-style
1261                     (list d2 m2 y2)
1262                   (list m2 d2 y2))))
1263         (d (calendar-absolute-from-gregorian date)))
1264     (if (and (<= date1 d) (<= d date2))
1265         entry)))
1266
1267 (defun diary-float (month dayname n)
1268   "Floating diary entry--entry applies if date is the nth dayname of month.
1269 Parameters are MONTH, DAYNAME, N.  MONTH can be a list of months, the constant
1270 t, or an integer.  The constant t means all months.  If N is negative, count
1271 backward from the end of the month."
1272   (let ((m (extract-calendar-month date))
1273         (y (extract-calendar-year date)))
1274     (if (and
1275          (or (and (listp month) (memq m month))
1276              (equal m month)
1277              (eq month t))
1278          (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
1279         entry)))
1280
1281 (defun diary-anniversary (month day year)
1282   "Anniversary diary entry.
1283 Entry applies if date is the anniversary of MONTH, DAY, YEAR if
1284 `european-calendar-style' is nil, and DAY, MONTH, YEAR if
1285 `european-calendar-style' is t.  Diary entry can contain `%d' or `%d%s'; the
1286 %d will be replaced by the number of years since the MONTH DAY, YEAR and the
1287 %s will be replaced by the ordinal ending of that number (that is, `st', `nd',
1288 `rd' or `th', as appropriate.  The anniversary of February 29 is considered
1289 to be March 1 in non-leap years."
1290   (let* ((d (if european-calendar-style
1291                 month
1292               day))
1293          (m (if european-calendar-style
1294                 day
1295               month))
1296          (y (extract-calendar-year date))
1297          (diff (- y year)))
1298     (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
1299         (setq m 3
1300               d 1))
1301     (if (and (> diff 0) (calendar-date-equal (list m d y) date))
1302         (format entry diff (diary-ordinal-suffix diff)))))
1303
1304 (defun diary-cyclic (n month day year)
1305   "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
1306 If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
1307 ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
1308 years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
1309 ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
1310   (let* ((d (if european-calendar-style
1311                 month
1312               day))
1313          (m (if european-calendar-style
1314                 day
1315               month))
1316          (diff (- (calendar-absolute-from-gregorian date)
1317                   (calendar-absolute-from-gregorian
1318                    (list m d year))))
1319          (cycle (/ diff n)))
1320     (if (and (>= diff 0) (zerop (% diff n)))
1321         (format entry cycle (diary-ordinal-suffix cycle)))))
1322
1323 (defun diary-ordinal-suffix (n)
1324   "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
1325   (if (or (memq (% n 100) '(11 12 13))
1326           (< 3 (% n 10)))
1327       "th"
1328     (aref ["th" "st" "nd" "rd"] (% n 10))))
1329
1330 (defun diary-day-of-year ()
1331   "Day of year and number of days remaining in the year of date diary entry."
1332   (calendar-day-of-year-string date))
1333
1334 (defun diary-iso-date ()
1335   "ISO calendar equivalent of date diary entry."
1336   (format "ISO date: %s" (calendar-iso-date-string date)))
1337
1338 (defun diary-islamic-date ()
1339   "Islamic calendar equivalent of date diary entry."
1340   (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
1341     (if (string-equal i "")
1342         "Date is pre-Islamic"
1343       (format "Islamic date (until sunset): %s" i))))
1344
1345 (defun diary-hebrew-date ()
1346   "Hebrew calendar equivalent of date diary entry."
1347   (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date)))
1348
1349 (defun diary-julian-date ()
1350   "Julian calendar equivalent of date diary entry."
1351   (format "Julian date: %s" (calendar-julian-date-string date)))
1352
1353 (defun diary-astro-day-number ()
1354   "Astronomical (Julian) day number diary entry."
1355   (format "Astronomical (Julian) day number %s"
1356           (calendar-astro-date-string date)))
1357
1358 (defun diary-omer ()
1359   "Omer count diary entry.
1360 Entry applies if date is within 50 days after Passover."
1361   (let* ((passover
1362           (calendar-absolute-from-hebrew
1363            (list 1 15 (+ (extract-calendar-year date) 3760))))
1364          (omer (- (calendar-absolute-from-gregorian date) passover))
1365          (week (/ omer 7))
1366          (day (% omer 7)))
1367     (if (and (> omer 0) (< omer 50))
1368         (format "Day %d%s of the omer (until sunset)"
1369                 omer
1370                 (if (zerop week)
1371                     ""
1372                   (format ", that is, %d week%s%s"
1373                           week
1374                           (if (= week 1) "" "s")
1375                           (if (zerop day)
1376                               ""
1377                             (format " and %d day%s"
1378                                     day (if (= day 1) "" "s")))))))))
1379
1380 (defun diary-yahrzeit (death-month death-day death-year)
1381   "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
1382 Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
1383 to be the name of the person.  Date of death is on the *civil* calendar;
1384 although the date of death is specified by the civil calendar, the proper
1385 Hebrew calendar yahrzeit is determined.  If `european-calendar-style' is t, the
1386 order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
1387   (let* ((h-date (calendar-hebrew-from-absolute
1388                   (calendar-absolute-from-gregorian
1389                    (if european-calendar-style
1390                        (list death-day death-month death-year)
1391                    (list death-month death-day death-year)))))
1392          (h-month (extract-calendar-month h-date))
1393          (h-day (extract-calendar-day h-date))
1394          (h-year (extract-calendar-year h-date))
1395          (d (calendar-absolute-from-gregorian date))
1396          (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
1397          (diff (- yr h-year))
1398          (y (hebrew-calendar-yahrzeit h-date yr)))
1399     (if (and (> diff 0) (or (= y d) (= y (1+ d))))
1400         (format "Yahrzeit of %s%s: %d%s anniversary"
1401                 entry
1402                 (if (= y d) "" " (evening)")
1403                 diff
1404                 (cond ((= (% diff 10) 1) "st")
1405                       ((= (% diff 10) 2) "nd")
1406                       ((= (% diff 10) 3) "rd")
1407                       (t "th"))))))
1408
1409 (defun diary-rosh-hodesh ()
1410   "Rosh Hodesh diary entry.
1411 Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
1412   (let* ((d (calendar-absolute-from-gregorian date))
1413          (h-date (calendar-hebrew-from-absolute d))
1414          (h-month (extract-calendar-month h-date))
1415          (h-day (extract-calendar-day h-date))
1416          (h-year (extract-calendar-year h-date))
1417          (leap-year (hebrew-calendar-leap-year-p h-year))
1418          (last-day (hebrew-calendar-last-day-of-month h-month h-year))
1419          (h-month-names
1420           (if leap-year
1421               calendar-hebrew-month-name-array-leap-year
1422             calendar-hebrew-month-name-array-common-year))
1423          (this-month (aref h-month-names (1- h-month)))
1424          (h-yesterday (extract-calendar-day
1425                        (calendar-hebrew-from-absolute (1- d)))))
1426     (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
1427         (format
1428          "Rosh Hodesh %s"
1429          (if (= h-day 30)
1430              (format
1431               "%s (first day)"
1432               ;; next month must be in the same year since this
1433               ;; month can't be the last month of the year since
1434               ;; it has 30 days
1435               (aref h-month-names h-month))
1436            (if (= h-yesterday 30)
1437                (format "%s (second day)" this-month)
1438              this-month)))
1439       (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim
1440           (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
1441                  (format "Mevarhim Rosh Hodesh %s (%s)"
1442                          (aref h-month-names
1443                                (if (= h-month
1444                                       (hebrew-calendar-last-month-of-year
1445                                        h-year))
1446                                    0 h-month))
1447                          (aref calendar-day-name-array (- 29 h-day))))
1448                 ((and (< h-day 30) (> h-day 22) (= 30 last-day))
1449                  (format "Mevarhim Rosh Hodesh %s (%s-%s)"
1450                          (aref h-month-names h-month)
1451                          (if (= h-day 29)
1452                              "tomorrow"
1453                            (aref calendar-day-name-array (- 29 h-day)))
1454                          (aref calendar-day-name-array
1455                                (% (- 30 h-day) 7)))))
1456         (if (and (= h-day 29) (/= h-month 6))
1457             (format "Erev Rosh Hodesh %s"
1458                     (aref h-month-names
1459                           (if (= h-month
1460                                  (hebrew-calendar-last-month-of-year
1461                                   h-year))
1462                               0 h-month))))))))
1463
1464 (defun diary-parasha ()
1465   "Parasha diary entry--entry applies if date is a Saturday."
1466   (let ((d (calendar-absolute-from-gregorian date)))
1467     (if (= (% d 7) 6);;  Saturday
1468         (let*
1469             ((h-year (extract-calendar-year
1470                       (calendar-hebrew-from-absolute d)))
1471              (rosh-hashannah
1472               (calendar-absolute-from-hebrew (list 7 1 h-year)))
1473              (passover
1474               (calendar-absolute-from-hebrew (list 1 15 h-year)))
1475              (rosh-hashannah-day
1476               (aref calendar-day-name-array (% rosh-hashannah 7)))
1477              (passover-day
1478               (aref calendar-day-name-array (% passover 7)))
1479              (long-h (hebrew-calendar-long-heshvan-p h-year))
1480              (short-k (hebrew-calendar-short-kislev-p h-year))
1481              (type (cond ((and long-h (not short-k)) "complete")
1482                          ((and (not long-h) short-k) "incomplete")
1483                          (t "regular")))
1484              (year-format
1485               (symbol-value
1486                (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
1487                                rosh-hashannah-day type passover-day))))
1488              (first-saturday;; of Hebrew year
1489               (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
1490              (saturday;; which Saturday of the Hebrew year
1491               (/ (- d first-saturday) 7))
1492              (parasha (aref year-format saturday)))
1493           (if parasha
1494               (format
1495                "Parashat %s"
1496                (if (listp parasha);; Israel differs from diaspora
1497                    (if (car parasha)
1498                        (format "%s (diaspora), %s (Israel)"
1499                                (hebrew-calendar-parasha-name (car parasha))
1500                                (hebrew-calendar-parasha-name (cdr parasha)))
1501                      (format "%s (Israel)"
1502                              (hebrew-calendar-parasha-name (cdr parasha))))
1503                  (hebrew-calendar-parasha-name parasha))))))))
1504
1505 (defun add-to-diary-list (date string)
1506   "Add the entry (DATE STRING) to `diary-entries-list'.
1507 Do nothing if DATE or STRING is nil."
1508   (and date string
1509        (setq diary-entries-list
1510              (append diary-entries-list (list (list date string))))))
1511
1512 (defvar hebrew-calendar-parashiot-names
1513 ["Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" "Toledoth"
1514  "Vayetze"     "Vayishlah" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
1515  "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
1516  "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
1517  "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Moth" "Kedoshim"
1518  "Emor"        "Behar"     "Behukkotai" "Bemidbar"  "Naso"       "Behaalot'cha"
1519  "Shelah L'cha" "Korah"    "Hukkath"    "Balak"     "Pinhas"      "Mattoth"
1520  "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
1521  "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu"]
1522   "The names of the parashiot in the Torah.")
1523
1524 ;; The seven ordinary year types (keviot)
1525
1526 (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
1527   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1528     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1529     43 44 45 46 47 48 49 50]
1530   "The structure of the parashiot.
1531 Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
1532 29 days), and has Passover start on Sunday.")
1533
1534 (defconst hebrew-calendar-year-Saturday-complete-Tuesday
1535   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1536     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1537     43 44 45 46 47 48 49 [50 51]]
1538   "The structure of the parashiot.
1539 Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1540 have 30 days), and has Passover start on Tuesday.")
1541
1542 (defconst hebrew-calendar-year-Monday-incomplete-Tuesday
1543   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1544     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1545     43 44 45 46 47 48 49 [50 51]]
1546   "The structure of the parashiot.
1547 Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1548 have 29 days), and has Passover start on Tuesday.")
1549
1550 (defconst hebrew-calendar-year-Monday-complete-Thursday
1551   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1552    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
1553    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1554   "The structure of the parashiot.
1555 Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
1556 30 days), and has Passover start on Thursday.")
1557
1558 (defconst hebrew-calendar-year-Tuesday-regular-Thursday
1559   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1560    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
1561    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1562   "The structure of the parashiot.
1563 Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1564 Kislev has 30 days), and has Passover start on Thursday.")
1565
1566 (defconst hebrew-calendar-year-Thursday-regular-Saturday
1567   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
1568    24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
1569    (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
1570    49 50]
1571   "The structure of the parashiot.
1572 Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
1573 Kislev has 30 days), and has Passover start on Saturday.")
1574
1575 (defconst hebrew-calendar-year-Thursday-complete-Sunday
1576   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1577     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1578     43 44 45 46 47 48 49 50]
1579   "The structure of the parashiot.
1580 Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
1581 have 30 days), and has Passover start on Sunday.")
1582
1583 ;; The seven leap year types (keviot)
1584
1585 (defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
1586   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1587     23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
1588     43 44 45 46 47 48 49 [50 51]]
1589   "The structure of the parashiot.
1590 Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
1591 have 29 days), and has Passover start on Tuesday.")
1592
1593 (defconst hebrew-calendar-year-Saturday-complete-Thursday
1594   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1595    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
1596    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1597   "The structure of the parashiot.
1598 Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1599 have 30 days), and has Passover start on Thursday.")
1600
1601 (defconst hebrew-calendar-year-Monday-incomplete-Thursday
1602   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1603    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
1604    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1605   "The structure of the parashiot.
1606 Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1607 have 29 days), and has Passover start on Thursday.")
1608
1609 (defconst hebrew-calendar-year-Monday-complete-Saturday
1610   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1611    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
1612    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
1613    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
1614   "The structure of the parashiot.
1615 Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
1616 30 days), and has Passover start on Saturday.")
1617
1618 (defconst hebrew-calendar-year-Tuesday-regular-Saturday
1619   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1620    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
1621    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
1622    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
1623   "The structure of the parashiot.
1624 Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1625 Kislev has 30 days), and has Passover start on Saturday.")
1626
1627 (defconst hebrew-calendar-year-Thursday-incomplete-Sunday
1628   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1629     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1630     43 44 45 46 47 48 49 50]
1631   "The structure of the parashiot.
1632 Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
1633 have 29 days), and has Passover start on Sunday.")
1634
1635 (defconst hebrew-calendar-year-Thursday-complete-Tuesday
1636   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1637     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1638     43 44 45 46 47 48 49 [50 51]]
1639   "The structure of the parashiot.
1640 Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
1641 have 30 days), and has Passover start on Tuesday.")
1642
1643 (defun hebrew-calendar-parasha-name (p)
1644   "Name(s) corresponding to parasha P."
1645   (if (arrayp p);; combined parasha
1646       (format "%s/%s"
1647               (aref hebrew-calendar-parashiot-names (aref p 0))
1648               (aref hebrew-calendar-parashiot-names (aref p 1)))
1649     (aref hebrew-calendar-parashiot-names p)))
1650
1651 (defun list-islamic-diary-entries ()
1652   "Add any Islamic date entries from the diary file to `diary-entries-list'.
1653 Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
1654 (normally an `I').  The same diary date forms govern the style of the Islamic
1655 calendar entries, except that the Islamic month names must be spelled in full.
1656 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1657 Dhu al-Hijjah.  If an Islamic date diary entry begins with a
1658 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
1659 not be marked in the calendar.  This function is provided for use with the
1660 `nongregorian-diary-listing-hook'."
1661   (if (< 0 number)
1662       (let ((buffer-read-only nil)
1663             (diary-modified (buffer-modified-p))
1664             (gdate original-date)
1665             (mark (regexp-quote diary-nonmarking-symbol)))
1666         (calendar-for-loop i from 1 to number do
1667            (let* ((d diary-date-forms)
1668                   (idate (calendar-islamic-from-absolute
1669                           (calendar-absolute-from-gregorian gdate)))
1670                   (month (extract-calendar-month idate))
1671                   (day (extract-calendar-day idate))
1672                   (year (extract-calendar-year idate)))
1673              (while d
1674                (let*
1675                    ((date-form (if (equal (car (car d)) 'backup)
1676                                    (cdr (car d))
1677                                  (car d)))
1678                     (backup (equal (car (car d)) 'backup))
1679                     (dayname
1680                      (concat
1681                       (calendar-day-name gdate) "\\|"
1682                       (substring (calendar-day-name gdate) 0 3) ".?"))
1683                     (calendar-month-name-array
1684                      calendar-islamic-month-name-array)
1685                     (monthname
1686                      (concat
1687                       "\\*\\|"
1688                       (calendar-month-name month)))
1689                     (month (concat "\\*\\|0*" (int-to-string month)))
1690                     (day (concat "\\*\\|0*" (int-to-string day)))
1691                     (year
1692                      (concat
1693                       "\\*\\|0*" (int-to-string year)
1694                       (if abbreviated-calendar-year
1695                           (concat "\\|" (int-to-string (% year 100)))
1696                         "")))
1697                     (regexp
1698                      (concat
1699                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
1700                       (regexp-quote islamic-diary-entry-symbol)
1701                       "\\("
1702                       (mapconcat 'eval date-form "\\)\\(")
1703                       "\\)"))
1704                     (case-fold-search t))
1705                  (goto-char (point-min))
1706                  (while (re-search-forward regexp nil t)
1707                    (if backup (re-search-backward "\\<" nil t))
1708                    (if (and (or (char-equal (preceding-char) ?\^M)
1709                                 (char-equal (preceding-char) ?\n))
1710                             (not (looking-at " \\|\^I")))
1711                        ;;  Diary entry that consists only of date.
1712                        (backward-char 1)
1713                      ;;  Found a nonempty diary entry--make it visible and
1714                      ;;  add it to the list.
1715                      (let ((entry-start (point))
1716                            (date-start))
1717                        (re-search-backward "\^M\\|\n\\|\\`")
1718                        (setq date-start (point))
1719                        (re-search-forward "\^M\\|\n" nil t 2)
1720                        (while (looking-at " \\|\^I")
1721                          (re-search-forward "\^M\\|\n" nil t))
1722                        (backward-char 1)
1723                        (subst-char-in-region date-start (point) ?\^M ?\n t)
1724                        (add-to-diary-list
1725                          gdate (buffer-substring entry-start (point)))))))
1726                (setq d (cdr d))))
1727            (setq gdate
1728                  (calendar-gregorian-from-absolute
1729                   (1+ (calendar-absolute-from-gregorian gdate)))))
1730            (set-buffer-modified-p diary-modified))
1731         (goto-char (point-min))))
1732
1733 (defun mark-islamic-diary-entries ()
1734   "Mark days in the calendar window that have Islamic date diary entries.
1735 Each entry in diary-file (or included files) visible in the calendar window
1736 is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
1737 (normally an `I').  The same diary-date-forms govern the style of the Islamic
1738 calendar entries, except that the Islamic month names must be spelled in full.
1739 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1740 Dhu al-Hijjah.  Islamic date diary entries that begin with a
1741 diary-nonmarking-symbol will not be marked in the calendar.  This function is
1742 provided for use as part of the nongregorian-diary-marking-hook."
1743   (let ((d diary-date-forms))
1744     (while d
1745       (let*
1746           ((date-form (if (equal (car (car d)) 'backup)
1747                           (cdr (car d))
1748                         (car d)));; ignore 'backup directive
1749            (dayname (diary-name-pattern calendar-day-name-array))
1750            (monthname
1751             (concat
1752              (diary-name-pattern calendar-islamic-month-name-array t)
1753              "\\|\\*"))
1754            (month "[0-9]+\\|\\*")
1755            (day "[0-9]+\\|\\*")
1756            (year "[0-9]+\\|\\*")
1757            (l (length date-form))
1758            (d-name-pos (- l (length (memq 'dayname date-form))))
1759            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
1760            (m-name-pos (- l (length (memq 'monthname date-form))))
1761            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
1762            (d-pos (- l (length (memq 'day date-form))))
1763            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
1764            (m-pos (- l (length (memq 'month date-form))))
1765            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
1766            (y-pos (- l (length (memq 'year date-form))))
1767            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
1768            (regexp
1769             (concat
1770              "\\(\\`\\|\^M\\|\n\\)"
1771              (regexp-quote islamic-diary-entry-symbol)
1772              "\\("
1773              (mapconcat 'eval date-form "\\)\\(")
1774              "\\)"))
1775            (case-fold-search t))
1776         (goto-char (point-min))
1777         (while (re-search-forward regexp nil t)
1778           (let* ((dd-name
1779                   (if d-name-pos
1780                       (buffer-substring
1781                        (match-beginning d-name-pos)
1782                        (match-end d-name-pos))))
1783                  (mm-name
1784                   (if m-name-pos
1785                       (buffer-substring
1786                        (match-beginning m-name-pos)
1787                        (match-end m-name-pos))))
1788                  (mm (string-to-int
1789                       (if m-pos
1790                           (buffer-substring
1791                            (match-beginning m-pos)
1792                            (match-end m-pos))
1793                         "")))
1794                  (dd (string-to-int
1795                       (if d-pos
1796                           (buffer-substring
1797                            (match-beginning d-pos)
1798                            (match-end d-pos))
1799                         "")))
1800                  (y-str (if y-pos
1801                             (buffer-substring
1802                              (match-beginning y-pos)
1803                              (match-end y-pos))))
1804                  (yy (if (not y-str)
1805                          0
1806                        (if (and (= (length y-str) 2)
1807                                 abbreviated-calendar-year)
1808                            (let* ((current-y
1809                                    (extract-calendar-year
1810                                     (calendar-islamic-from-absolute
1811                                      (calendar-absolute-from-gregorian
1812                                       (calendar-current-date)))))
1813                                   (y (+ (string-to-int y-str)
1814                                         (* 100 (/ current-y 100)))))
1815                              (if (> (- y current-y) 50)
1816                                  (- y 100)
1817                                (if (> (- current-y y) 50)
1818                                    (+ y 100)
1819                                  y)))
1820                          (string-to-int y-str)))))
1821             (if dd-name
1822                 (mark-calendar-days-named
1823                  (cdr (assoc (capitalize (substring dd-name 0 3))
1824                              (calendar-make-alist
1825                                calendar-day-name-array
1826                                0
1827                                '(lambda (x) (substring x 0 3))))))
1828               (if mm-name
1829                   (if (string-equal mm-name "*")
1830                       (setq mm 0)
1831                     (setq mm
1832                           (cdr (assoc
1833                                 (capitalize mm-name)
1834                                 (calendar-make-alist
1835                                   calendar-islamic-month-name-array))))))
1836               (mark-islamic-calendar-date-pattern mm dd yy)))))
1837       (setq d (cdr d)))))
1838
1839 (defun mark-islamic-calendar-date-pattern (month day year)
1840   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
1841 A value of 0 in any position is a wildcard."
1842   (save-excursion
1843     (set-buffer calendar-buffer)
1844     (if (and (/= 0 month) (/= 0 day))
1845         (if (/= 0 year)
1846             ;; Fully specified Islamic date.
1847             (let ((date (calendar-gregorian-from-absolute
1848                          (calendar-absolute-from-islamic
1849                           (list month day year)))))
1850               (if (calendar-date-is-visible-p date)
1851                   (mark-visible-calendar-date date)))
1852           ;; Month and day in any year--this taken from the holiday stuff.
1853           (let* ((islamic-date (calendar-islamic-from-absolute
1854                                 (calendar-absolute-from-gregorian
1855                                  (list displayed-month 15 displayed-year))))
1856                  (m (extract-calendar-month islamic-date))
1857                  (y (extract-calendar-year islamic-date))
1858                  (date))
1859             (if (< m 1)
1860                 nil;;   Islamic calendar doesn't apply.
1861               (increment-calendar-month m y (- 10 month))
1862               (if (> m 7);;  Islamic date might be visible
1863                   (let ((date (calendar-gregorian-from-absolute
1864                                (calendar-absolute-from-islamic
1865                                 (list month day y)))))
1866                     (if (calendar-date-is-visible-p date)
1867                         (mark-visible-calendar-date date)))))))
1868       ;; Not one of the simple cases--check all visible dates for match.
1869       ;; Actually, the following code takes care of ALL of the cases, but
1870       ;; it's much too slow to be used for the simple (common) cases.
1871       (let ((m displayed-month)
1872             (y displayed-year)
1873             (first-date)
1874             (last-date))
1875         (increment-calendar-month m y -1)
1876         (setq first-date
1877               (calendar-absolute-from-gregorian
1878                (list m 1 y)))
1879         (increment-calendar-month m y 2)
1880         (setq last-date
1881               (calendar-absolute-from-gregorian
1882                (list m (calendar-last-day-of-month m y) y)))
1883         (calendar-for-loop date from first-date to last-date do
1884           (let* ((i-date (calendar-islamic-from-absolute date))
1885                  (i-month (extract-calendar-month i-date))
1886                  (i-day (extract-calendar-day i-date))
1887                  (i-year (extract-calendar-year i-date)))
1888             (and (or (zerop month)
1889                      (= month i-month))
1890                  (or (zerop day)
1891                      (= day i-day))
1892                  (or (zerop year)
1893                      (= year i-year))
1894                  (mark-visible-calendar-date
1895                   (calendar-gregorian-from-absolute date)))))))))
1896
1897 (provide 'diary)
1898
1899 ;;; diary.el ends here