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