lisp/diary-lib.el

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