lisp/diary-lib.el

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