lisp/diary-lib.el

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