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