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