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