lisp/diary-lib.el

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