comparison lisp/calendar/calendar.el @ 92969:bb4fc128d00d

(european-calendar-style, calendar-for-loop) (calendar-sum, calendar-insert-indented, mouse-calendar-other-month) (calendar-cursor-to-date): Doc fix. (hebrew-holidays-1, hebrew-holidays-4): Simplify. (extract-calendar-day, extract-calendar-year): Use cadr, nth. (calendar-day-number): Use when. (generate-calendar-month): Use dotimes. (exit-calendar, calendar-print-other-dates): Use let rather than let*. (calendar-set-mark): Reverse conditional. (calendar-make-alist): Move definition before use.

92968:e2f0046a8cb4

;; Hard copies of these two papers can be obtained by sending email to
;; [e-mail] with the SUBJECT "send-paper-cal" (no quotes) and
;; the message BODY containing your mailing address (snail).

;;; Code:

;; (elisp) Eval During Compile: "Effectively `require' is
;; automatically `eval-and-compile'" [but `load' is not]
(eval-and-compile

  :group 'diary)

;;;###autoload
(defcustom european-calendar-style nil
  "Use the European style of dates in the diary and in any displays.
If this variable is t, a date 1/2/1990 would be interpreted as February 1,
1990.  The default European date styles (see `european-date-diary-pattern')
are

            DAY/MONTH
            DAY/MONTH/YEAR
            DAY MONTHNAME
            DAY MONTHNAME YEAR

(defvar hebrew-holidays-1
  '((holiday-rosh-hashanah-etc)
    (if all-hebrew-calendar-holidays
        (holiday-julian
         11
         (let* ((m displayed-month)
                (y displayed-year)
                (year))
           (increment-calendar-month m y -1)
           (let ((year (extract-calendar-year
                        (calendar-julian-from-absolute
                         (calendar-absolute-from-gregorian
                          (list m 1 y))))))
             (if (zerop (% (1+ year) 4))
                 22
               21))) "\"Tal Umatar\" (evening)")))
  "Component of the default value of `hebrew-holidays'.")
;;;###autoload
(put 'hebrew-holidays-1 'risky-local-variable t)

;;;###autoload

       10
       (let ((h-year (extract-calendar-year
                      (calendar-hebrew-from-absolute
                       (calendar-absolute-from-gregorian
                        (list displayed-month 28 displayed-year))))))
         (if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year))
                   7)
                6)
             11 10))
       "Tzom Teveth"))
    (if all-hebrew-calendar-holidays
        (holiday-hebrew 11 15 "Tu B'Shevat")))
  "Component of the default value of `hebrew-holidays'.")

                             (list m
                                   (calendar-last-day-of-month m y)
                                   y)))))
                  (s-s
                   (calendar-hebrew-from-absolute
                    (if (=
                         (% (calendar-absolute-from-hebrew
                             (list 7 1 h-year))
                            7)
                         6)
                        (calendar-dayname-on-or-before
                         6 (calendar-absolute-from-hebrew
                            (list 11 17 h-year)))
                      (calendar-dayname-on-or-before
                       6 (calendar-absolute-from-hebrew

;;;###autoload
(defvar hebrew-holidays-4
  '((holiday-passover-etc)
    (if (and all-hebrew-calendar-holidays
             (let* ((m displayed-month)
                    (y displayed-year)
                    (year))
               (increment-calendar-month m y -1)
               (let ((year (extract-calendar-year
                            (calendar-julian-from-absolute
                             (calendar-absolute-from-gregorian
                              (list m 1 y))))))
                 (= 21 (% year 28)))))
        (holiday-julian 3 26 "Kiddush HaHamah"))
    (if all-hebrew-calendar-holidays
        (holiday-tisha-b-av-etc)))
    "Component of the default value of `hebrew-holidays'.")
;;;###autoload

  (cons mon yr))

(defmacro calendar-for-loop (var from init to final do &rest body)
  "Execute a for loop.
Evaluate BODY with VAR bound to successive integers from INIT to FINAL,
inclusive."
  (declare (debug (symbolp "from" form "to" form "do" body)))
  `(let ((,var (1- ,init)))
    (while (>= ,final (setq ,var (1+ ,var)))
      ,@body)))

(defmacro calendar-sum (index initial condition expression)
  "For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION."
  (declare (debug (symbolp form form form)))
  `(let ((,index ,initial)
         (sum 0))
    (while ,condition
      (setq sum (+ sum ,expression))
      (setq ,index (1+ ,index)))
    sum))

;; The following are in-line for speed; they can be called thousands of times
;; when looking up holidays or processing the diary.  Here, for example, are
;; the numbers of calls to calendar/diary/holiday functions in preparing the

  (car date))

;; Note gives wrong answer for result of (calendar-read-date 'noday).
(defsubst extract-calendar-day (date)
  "Extract the day part of DATE which has the form (month day year)."
  (car (cdr date)))

(defsubst extract-calendar-year (date)
  "Extract the year part of DATE which has the form (month day year)."
  (car (cdr (cdr date))))

(defsubst calendar-leap-year-p (year)
  "Return t if YEAR is a Gregorian leap year.
A negative year is interpreted as BC; -1 being 1 BC, and so on."
  ;; 1 BC = 0 AD, 2 BC acts like 1 AD, etc.

(defsubst calendar-day-number (date)
  "Return the day number within the year of the date DATE.
For example, (calendar-day-number '(1 1 1987)) returns the value 1,
while (calendar-day-number '(12 31 1980)) returns 366."
    (let* ((month (extract-calendar-month date))
           (day (extract-calendar-day date))
           (year (extract-calendar-year date))
         (day-of-year (+ day (* 31 (1- month)))))
      (if (> month 2)
          (progn
            (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
            (if (calendar-leap-year-p year)
                (setq day-of-year (1+ day-of-year)))))
      day-of-year))

(defsubst calendar-absolute-from-gregorian (date)
  "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
The Gregorian date Sunday, December 31, 1 BC is imaginary.
DATE is a list of the form (month day year).  A negative year is

  (interactive "P")
  (set-buffer (get-buffer-create calendar-buffer))
  (calendar-mode)
  (let* ((pop-up-windows t)
         (split-height-threshold 1000)
         (date (if arg
                   (calendar-read-date t)
                 (calendar-current-date)))
         (month (extract-calendar-month date))
         (year (extract-calendar-year date)))
    ;; (calendar-read-date t) returns a date with day = nil, which is
    ;; not a valid date for the visible test in the diary section.

  "Produce a calendar for MONTH, YEAR on the Gregorian calendar.
The calendar is inserted at the top of the buffer in which point is currently
located, but indented INDENT spaces.  The indentation is done from the first
character on the line and does not disturb the first INDENT characters on the
line."
  (let* ((blank-days                    ; at start of month
          (mod
           (- (calendar-day-of-week (list month 1 year))
              calendar-week-start-day)
           7))
         (last (calendar-last-day-of-month month year)))
   (goto-char (point-min))
   (calendar-insert-indented
    (calendar-string-spread
     (list (format "%s %d" (calendar-month-name month) year)) ?  20)

   (calendar-insert-indented "" 0 t)    ; force onto following line
   (calendar-insert-indented "" indent) ; go to proper spot
   ;; Add blank days before the first of the month.
   (dotimes (idummy blank-days) (insert "   "))
   ;; Put in the days of the month.
   (calendar-for-loop i from 1 to last do
      (insert (format "%2d " i))
      (add-text-properties
       (- (point) 3) (1- (point))
       '(mouse-face highlight
         help-echo "mouse-2: menu of operations for this date"))
      (and (zerop (mod (+ i blank-days) 7))
           (/= i last)
           (calendar-insert-indented "" 0 t) ; force onto following line
           (calendar-insert-indented "" indent))))) ; go to proper spot

(defun calendar-insert-indented (string indent &optional newline)
  "Insert STRING at column INDENT.
If the optional parameter NEWLINE is t, leave point at start of next line,
inserting a newline if there was no next line; otherwise, leave point after
the inserted text.  Returns t."
  ;; Try to move to that column.
  (move-to-column indent)
  ;; If line is too short, indent out to that column.
  (if (< (current-column) indent)
      (indent-to indent))

       \"\"))"
  :type 'sexp
  :group 'calendar)

(defun mouse-calendar-other-month (event)
  "Display a three-month calendar centered around a specified month and year."
  (interactive "e")
  (save-selected-window
    (select-window (posn-window (event-start event)))
    (call-interactively 'calendar-other-month)))

    buffs))

(defun exit-calendar ()
  "Get out of the calendar window and hide it and related buffers."
  (interactive)
  (let* ((diary-buffer (get-file-buffer diary-file)))
    (if (or (not diary-buffer)
            (not (buffer-modified-p diary-buffer))
            (yes-or-no-p
             "Diary modified; do you really want to exit the calendar? "))
        ;; Need to do this multiple times because one time can replace some

    (list (nth 4 now) (nth 3 now) (nth 5 now))))

(defun calendar-cursor-to-date (&optional error)
  "Return a list (month day year) of current cursor position.
If cursor is not on a specific date, signals an error if optional parameter
ERROR is t, otherwise just returns nil."
  (let* ((segment (/ (current-column) 25))
         (month (% (+ displayed-month segment -1) 12))
         (month (if (zerop month) 12 month))
         (year
          (cond

  "Mark the date under the cursor, or jump to marked date.
With no prefix argument, push current date onto marked date ring.
With argument ARG, jump to mark, pop it, and put point at end of ring."
  (interactive "P")
  (let ((date (calendar-cursor-to-date t)))
    (if (null arg)
        (progn
          (push date calendar-mark-ring)
          ;; Since the top of the mark ring is the marked date in the
          ;; calendar, the mark ring in the calendar is one longer than
          ;; in other buffers to get the same effect.
          (if (> (length calendar-mark-ring) (1+ mark-ring-max))
              (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil))
          (message "Mark set"))
      (if (null calendar-mark-ring)
          (error "No mark set in this buffer")
        (calendar-goto-date (car calendar-mark-ring))
        (setq calendar-mark-ring
              (cdr (nconc calendar-mark-ring (list date))))))))

(defun calendar-exchange-point-and-mark ()
  "Exchange the current cursor position with the marked date."
  (interactive)
  (let ((mark (car calendar-mark-ring))

file.  Do not include a trailing `.' in the strings specified in
this variable, though you may use such in the diary file.  If any
element of this array is nil, then the abbreviation will be
constructed as the first `calendar-abbrev-length' characters of the
corresponding full name.")


(defun calendar-read-date (&optional noday)
  "Prompt for Gregorian date.  Return a list (month day year).
If optional NODAY is t, does not ask for day, but just returns
\(month nil year); if NODAY is any other non-nil value the value returned is
\(month year)"
  (let* ((year (calendar-read
                "Year (>0): "
                (lambda (x) (> x 0))
                (int-to-string (extract-calendar-year
                                (calendar-current-date)))))
         (month-array calendar-month-name-array)
         (completion-ignore-case t)
         (month (cdr (assoc-string
                       (completing-read
                        "Month name: "
                        (mapcar 'list (append month-array nil))
                        nil t)
                      (calendar-make-alist month-array 1) t)))
         (last (calendar-last-day-of-month month year)))
    (if noday
        (if (eq noday t)
            (list month nil year)
          (list month year))
      (list month
            (calendar-read (format "Day (1-%d): " last)
                           (lambda (x) (and (< 0 x) (<= x last))))
            year))))

(defun calendar-interval (mon1 yr1 mon2 yr2)
  "The number of months difference between MON1, YR1 and MON2, YR2.
The result is positive if the second date is later than the first.
Negative years are interpreted as years BC; -1 being 1 BC, and so on."
  (if (< yr1 0) (setq yr1 (1+ yr1)))      ; -1 BC -> 0 AD, etc
  (if (< yr2 0) (setq yr2 (1+ yr2)))
  (+ (* 12 (- yr2 yr1))
     (- mon2 mon1)))

(defun calendar-abbrev-construct (abbrev full &optional period)
  "Internal calendar function to return a complete abbreviation array.
ABBREV is an array of abbreviations, FULL the corresponding array
of full names.  The return value is the ABBREV array, with any nil
elements replaced by the first three characters taken from the
corresponding element of FULL.  If optional argument PERIOD is non-nil,
each element returned has a final `.' character."
  (let (elem array name)
    (dotimes (i (length full))
      (setq name (aref full i)
            elem (or (aref abbrev i)
                     (substring name 0
                                (min calendar-abbrev-length (length name))))
            elem (format "%s%s" elem (if period "." ""))
            array (append array (list elem))))
    (vconcat array)))

(defvar calendar-font-lock-keywords
  `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
              " -?[0-9]+")
     . font-lock-function-name-face) ; month and year
    (,(regexp-opt
       (list (substring (aref calendar-day-name-array 6) 0 2)
             (substring (aref calendar-day-name-array 0) 0 2)))
     ;; Saturdays and Sundays are highlighted differently.
     . font-lock-comment-face)
    ;; First two chars of each day are used in the calendar.
    (,(regexp-opt (mapcar (lambda (x) (substring x 0 2))
                          calendar-day-name-array))
     . font-lock-reference-face))
  "Default keywords to highlight in Calendar mode.")

(defun calendar-day-name (date &optional abbrev absolute)
  "Return a string with the name of the day of the week of DATE.
DATE should be a list in the format (MONTH DAY YEAR), unless the
optional argument ABSOLUTE is non-nil, in which case DATE should
be an integer in the range 0 to 6 corresponding to the day of the
week.  Day names are taken from the variable `calendar-day-name-array',
unless the optional argument ABBREV is non-nil, in which case
the variable `calendar-day-abbrev-array' is used."
  (aref (if abbrev
            (calendar-abbrev-construct calendar-day-abbrev-array
                                       calendar-day-name-array)
          calendar-day-name-array)
        (if absolute date (calendar-day-of-week date))))

(defun calendar-make-alist (sequence &optional start-index filter abbrevs)
  "Make an assoc list corresponding to SEQUENCE.
Each element of sequence will be associated with an integer, starting
from 1, or from START-INDEX if that is non-nil.  If a sequence ABBREVS

                                  index) alist)))
      (if aseqp
          (setq elem (elt aseqp i)
                alist (cons (cons (if filter (funcall filter elem) elem)
                                  index) alist))))))

(defun calendar-month-name (month &optional abbrev)
  "Return a string with the name of month number MONTH.
Months are numbered from one.  Month names are taken from the
variable `calendar-month-name-array', unless the optional

An optional parameter ABBREVIATE, when non-nil, causes the month
and day names to be abbreviated as specified by
`calendar-month-abbrev-array' and `calendar-day-abbrev-array',
respectively.  An optional parameter NODAYNAME, when t, omits the
name of the day of the week."
  (let* ((dayname
          (unless nodayname
            (calendar-day-name date abbreviate)))
         (month (extract-calendar-month date))
         (monthname (calendar-month-name month abbreviate))
         (day (int-to-string (extract-calendar-day date)))
         (month (int-to-string month))
         (year (int-to-string (extract-calendar-year date))))

            day year days-remaining (if (= days-remaining 1) "" "s"))))

(defun calendar-print-other-dates ()
  "Show dates on other calendars for date under the cursor."
  (interactive)
  (let* ((date (calendar-cursor-to-date t)))
    (with-current-buffer (get-buffer-create other-calendars-buffer)
      (let ((inhibit-read-only t)
            (modified (buffer-modified-p)))
        (calendar-set-mode-line
         (concat (calendar-date-string date) " (Gregorian)"))

(defun calendar-set-mode-line (str)
  "Set mode line to STR, centered, surrounded by dashes."
  (let* ((edges (window-edges))
         ;; As per doc of window-width, total visible mode-line length.
         (width (- (nth 2 edges) (nth 0 edges))))
    (setq mode-line-format
          (if buffer-file-name
              `("-" mode-line-modified
                ,(calendar-string-spread (list str) ?- (- width 6))
                "---")

92969:bb4fc128d00d

;; Hard copies of these two papers can be obtained by sending email to
;; [e-mail] with the SUBJECT "send-paper-cal" (no quotes) and
;; the message BODY containing your mailing address (snail).


;; A note on free variables:

;; The calendar passes around a few dynamically bound variables, which
;; unfortunately have rather common names.  They are meant to be
;; available for external functions, so the names can't be changed.

;; displayed-month, displayed-year: bound in generate-calendar, the
;;   central month of the 3 month calendar window
;; original-date, number: bound in diary-list-entries, the arguments
;;   with which that function was called.
;; date, entry: bound in list-sexp-diary-entries (qv)

;; Bound in diary-list-entries:
;; diary-entries-list: use in d-l, appt.el, and by add-to-diary-list
;; diary-saved-point: only used in diary-lib.el, passed to the display func
;; date-string: only used in diary-lib.el FIXME could be removed?

;;; Code:

;; (elisp) Eval During Compile: "Effectively `require' is
;; automatically `eval-and-compile'" [but `load' is not]
(eval-and-compile

  :group 'diary)

;;;###autoload
(defcustom european-calendar-style nil
  "Use the European style of dates in the diary and in any displays.
If this variable is non-nil, a date 1/2/1990 would be interpreted as
February 1, 1990.  The default European date styles (see
`european-date-diary-pattern') are

            DAY/MONTH
            DAY/MONTH/YEAR
            DAY MONTHNAME
            DAY MONTHNAME YEAR

(defvar hebrew-holidays-1
  '((holiday-rosh-hashanah-etc)
    (if all-hebrew-calendar-holidays
        (holiday-julian
         11
         (let ((m displayed-month)
               (y displayed-year)
               year)
           (increment-calendar-month m y -1)
           (setq year (extract-calendar-year
                       (calendar-julian-from-absolute
                        (calendar-absolute-from-gregorian (list m 1 y)))))
           (if (zerop (% (1+ year) 4))
               22
             21)) "\"Tal Umatar\" (evening)")))
  "Component of the default value of `hebrew-holidays'.")
;;;###autoload
(put 'hebrew-holidays-1 'risky-local-variable t)

;;;###autoload

       10
       (let ((h-year (extract-calendar-year
                      (calendar-hebrew-from-absolute
                       (calendar-absolute-from-gregorian
                        (list displayed-month 28 displayed-year))))))
         (if (= 6 (% (calendar-absolute-from-hebrew (list 10 10 h-year))
                     7))
             11 10))
       "Tzom Teveth"))
    (if all-hebrew-calendar-holidays
        (holiday-hebrew 11 15 "Tu B'Shevat")))
  "Component of the default value of `hebrew-holidays'.")

                             (list m
                                   (calendar-last-day-of-month m y)
                                   y)))))
                  (s-s
                   (calendar-hebrew-from-absolute
                    (if (= 6
                           (% (calendar-absolute-from-hebrew
                               (list 7 1 h-year))
                              7))
                        (calendar-dayname-on-or-before
                         6 (calendar-absolute-from-hebrew
                            (list 11 17 h-year)))
                      (calendar-dayname-on-or-before
                       6 (calendar-absolute-from-hebrew

;;;###autoload
(defvar hebrew-holidays-4
  '((holiday-passover-etc)
    (if (and all-hebrew-calendar-holidays
             (let ((m displayed-month)
                   (y displayed-year)
                   year)
               (increment-calendar-month m y -1)
               (setq year (extract-calendar-year
                           (calendar-julian-from-absolute
                            (calendar-absolute-from-gregorian
                             (list m 1 y)))))
               (= 21 (% year 28))))
        (holiday-julian 3 26 "Kiddush HaHamah"))
    (if all-hebrew-calendar-holidays
        (holiday-tisha-b-av-etc)))
    "Component of the default value of `hebrew-holidays'.")
;;;###autoload

  (cons mon yr))

(defmacro calendar-for-loop (var from init to final do &rest body)
  "Execute a for loop.
Evaluate BODY with VAR bound to successive integers from INIT to FINAL,
inclusive.  The standard macro `dotimes' is preferable in most cases."
  (declare (debug (symbolp "from" form "to" form "do" body)))
  `(let ((,var (1- ,init)))
    (while (>= ,final (setq ,var (1+ ,var)))
      ,@body)))

(defmacro calendar-sum (index initial condition expression)
  "For INDEX = INITIAL, +1, ... (as long as CONDITION holds), sum EXPRESSION."
  (declare (debug (symbolp form form form)))
  `(let ((,index ,initial)
         (sum 0))
    (while ,condition
      (setq sum (+ sum ,expression)
            ,index (1+ ,index)))
    sum))

;; The following are in-line for speed; they can be called thousands of times
;; when looking up holidays or processing the diary.  Here, for example, are
;; the numbers of calls to calendar/diary/holiday functions in preparing the

  (car date))

;; Note gives wrong answer for result of (calendar-read-date 'noday).
(defsubst extract-calendar-day (date)
  "Extract the day part of DATE which has the form (month day year)."
  (cadr date))

(defsubst extract-calendar-year (date)
  "Extract the year part of DATE which has the form (month day year)."
  (nth 2 date))

(defsubst calendar-leap-year-p (year)
  "Return t if YEAR is a Gregorian leap year.
A negative year is interpreted as BC; -1 being 1 BC, and so on."
  ;; 1 BC = 0 AD, 2 BC acts like 1 AD, etc.

(defsubst calendar-day-number (date)
  "Return the day number within the year of the date DATE.
For example, (calendar-day-number '(1 1 1987)) returns the value 1,
while (calendar-day-number '(12 31 1980)) returns 366."
  (let* ((month (extract-calendar-month date))
         (day (extract-calendar-day date))
         (year (extract-calendar-year date))
         (day-of-year (+ day (* 31 (1- month)))))
    (when (> month 2)
      (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
      (if (calendar-leap-year-p year)
          (setq day-of-year (1+ day-of-year))))
    day-of-year))

(defsubst calendar-absolute-from-gregorian (date)
  "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
The Gregorian date Sunday, December 31, 1 BC is imaginary.
DATE is a list of the form (month day year).  A negative year is

  (interactive "P")
  (set-buffer (get-buffer-create calendar-buffer))
  (calendar-mode)
  (let* ((pop-up-windows t)
         (split-height-threshold 1000)
         (date (if arg (calendar-read-date t)
                 (calendar-current-date)))
         (month (extract-calendar-month date))
         (year (extract-calendar-year date)))
    ;; (calendar-read-date t) returns a date with day = nil, which is
    ;; not a valid date for the visible test in the diary section.

  "Produce a calendar for MONTH, YEAR on the Gregorian calendar.
The calendar is inserted at the top of the buffer in which point is currently
located, but indented INDENT spaces.  The indentation is done from the first
character on the line and does not disturb the first INDENT characters on the
line."
  (let ((blank-days                     ; at start of month
         (mod
          (- (calendar-day-of-week (list month 1 year))
             calendar-week-start-day)
          7))
         (last (calendar-last-day-of-month month year)))
   (goto-char (point-min))
   (calendar-insert-indented
    (calendar-string-spread
     (list (format "%s %d" (calendar-month-name month) year)) ?  20)

   (calendar-insert-indented "" 0 t)    ; force onto following line
   (calendar-insert-indented "" indent) ; go to proper spot
   ;; Add blank days before the first of the month.
   (dotimes (idummy blank-days) (insert "   "))
   ;; Put in the days of the month.
   (dotimes (i last)
     (insert (format "%2d " (1+ i)))
     (add-text-properties
      (- (point) 3) (1- (point))
      '(mouse-face highlight
                   help-echo "mouse-2: menu of operations for this date"))
     (and (zerop (mod (+ i 1 blank-days) 7))
          (/= i (1- last))
          (calendar-insert-indented "" 0 t) ; force onto following line
          (calendar-insert-indented "" indent))))) ; go to proper spot

(defun calendar-insert-indented (string indent &optional newline)
  "Insert STRING at column INDENT.
If the optional parameter NEWLINE is non-nil, leave point at start of next
line, inserting a newline if there was no next line; otherwise, leave point
after the inserted text.  Returns t."
  ;; Try to move to that column.
  (move-to-column indent)
  ;; If line is too short, indent out to that column.
  (if (< (current-column) indent)
      (indent-to indent))

       \"\"))"
  :type 'sexp
  :group 'calendar)

(defun mouse-calendar-other-month (event)
  "Display a three-month calendar centered around a specified month and year.
EVENT is the last mouse event."
  (interactive "e")
  (save-selected-window
    (select-window (posn-window (event-start event)))
    (call-interactively 'calendar-other-month)))

    buffs))

(defun exit-calendar ()
  "Get out of the calendar window and hide it and related buffers."
  (interactive)
  (let ((diary-buffer (get-file-buffer diary-file)))
    (if (or (not diary-buffer)
            (not (buffer-modified-p diary-buffer))
            (yes-or-no-p
             "Diary modified; do you really want to exit the calendar? "))
        ;; Need to do this multiple times because one time can replace some

    (list (nth 4 now) (nth 3 now) (nth 5 now))))

(defun calendar-cursor-to-date (&optional error)
  "Return a list (month day year) of current cursor position.
If cursor is not on a specific date, signals an error if optional parameter
ERROR is non-nil, otherwise just returns nil."
  (let* ((segment (/ (current-column) 25))
         (month (% (+ displayed-month segment -1) 12))
         (month (if (zerop month) 12 month))
         (year
          (cond

  "Mark the date under the cursor, or jump to marked date.
With no prefix argument, push current date onto marked date ring.
With argument ARG, jump to mark, pop it, and put point at end of ring."
  (interactive "P")
  (let ((date (calendar-cursor-to-date t)))
    (if arg
        (if (null calendar-mark-ring)
            (error "No mark set in this buffer")
          (calendar-goto-date (car calendar-mark-ring))
          (setq calendar-mark-ring
                (cdr (nconc calendar-mark-ring (list date)))))
      (push date calendar-mark-ring)
      ;; Since the top of the mark ring is the marked date in the
      ;; calendar, the mark ring in the calendar is one longer than
      ;; in other buffers to get the same effect.
      (if (> (length calendar-mark-ring) (1+ mark-ring-max))
          (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil))
      (message "Mark set"))))

(defun calendar-exchange-point-and-mark ()
  "Exchange the current cursor position with the marked date."
  (interactive)
  (let ((mark (car calendar-mark-ring))

file.  Do not include a trailing `.' in the strings specified in
this variable, though you may use such in the diary file.  If any
element of this array is nil, then the abbreviation will be
constructed as the first `calendar-abbrev-length' characters of the
corresponding full name.")

(defun calendar-make-alist (sequence &optional start-index filter abbrevs)
  "Make an assoc list corresponding to SEQUENCE.
Each element of sequence will be associated with an integer, starting
from 1, or from START-INDEX if that is non-nil.  If a sequence ABBREVS

                                  index) alist)))
      (if aseqp
          (setq elem (elt aseqp i)
                alist (cons (cons (if filter (funcall filter elem) elem)
                                  index) alist))))))

(defun calendar-read-date (&optional noday)
  "Prompt for Gregorian date.  Return a list (month day year).
If optional NODAY is t, does not ask for day, but just returns
\(month nil year); if NODAY is any other non-nil value the value returned is
\(month year)"
  (let* ((year (calendar-read
                "Year (>0): "
                (lambda (x) (> x 0))
                (int-to-string (extract-calendar-year
                                (calendar-current-date)))))
         (month-array calendar-month-name-array)
         (completion-ignore-case t)
         (month (cdr (assoc-string
                       (completing-read
                        "Month name: "
                        (mapcar 'list (append month-array nil))
                        nil t)
                      (calendar-make-alist month-array 1) t)))
         (last (calendar-last-day-of-month month year)))
    (if noday
        (if (eq noday t)
            (list month nil year)
          (list month year))
      (list month
            (calendar-read (format "Day (1-%d): " last)
                           (lambda (x) (and (< 0 x) (<= x last))))
            year))))

(defun calendar-interval (mon1 yr1 mon2 yr2)
  "The number of months difference between MON1, YR1 and MON2, YR2.
The result is positive if the second date is later than the first.
Negative years are interpreted as years BC; -1 being 1 BC, and so on."
  (if (< yr1 0) (setq yr1 (1+ yr1)))      ; -1 BC -> 0 AD, etc
  (if (< yr2 0) (setq yr2 (1+ yr2)))
  (+ (* 12 (- yr2 yr1))
     (- mon2 mon1)))

(defun calendar-abbrev-construct (abbrev full &optional period)
  "Internal calendar function to return a complete abbreviation array.
ABBREV is an array of abbreviations, FULL the corresponding array
of full names.  The return value is the ABBREV array, with any nil
elements replaced by the first three characters taken from the
corresponding element of FULL.  If optional argument PERIOD is non-nil,
each element returned has a final `.' character."
  (let (elem array name)
    (dotimes (i (length full))
      (setq name (aref full i)
            elem (or (aref abbrev i)
                     (substring name 0
                                (min calendar-abbrev-length (length name))))
            elem (format "%s%s" elem (if period "." ""))
            array (append array (list elem))))
    (vconcat array)))

(defvar calendar-font-lock-keywords
  `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
              " -?[0-9]+")
     . font-lock-function-name-face) ; month and year
    (,(regexp-opt
       (list (substring (aref calendar-day-name-array 6) 0 2)
             (substring (aref calendar-day-name-array 0) 0 2)))
     ;; Saturdays and Sundays are highlighted differently.
     . font-lock-comment-face)
    ;; First two chars of each day are used in the calendar.
    (,(regexp-opt (mapcar (lambda (x) (substring x 0 2))
                          calendar-day-name-array))
     . font-lock-reference-face))
  "Default keywords to highlight in Calendar mode.")

(defun calendar-day-name (date &optional abbrev absolute)
  "Return a string with the name of the day of the week of DATE.
DATE should be a list in the format (MONTH DAY YEAR), unless the
optional argument ABSOLUTE is non-nil, in which case DATE should
be an integer in the range 0 to 6 corresponding to the day of the
week.  Day names are taken from the variable `calendar-day-name-array',
unless the optional argument ABBREV is non-nil, in which case
the variable `calendar-day-abbrev-array' is used."
  (aref (if abbrev
            (calendar-abbrev-construct calendar-day-abbrev-array
                                       calendar-day-name-array)
          calendar-day-name-array)
        (if absolute date (calendar-day-of-week date))))

(defun calendar-month-name (month &optional abbrev)
  "Return a string with the name of month number MONTH.
Months are numbered from one.  Month names are taken from the
variable `calendar-month-name-array', unless the optional

An optional parameter ABBREVIATE, when non-nil, causes the month
and day names to be abbreviated as specified by
`calendar-month-abbrev-array' and `calendar-day-abbrev-array',
respectively.  An optional parameter NODAYNAME, when t, omits the
name of the day of the week."
  (let* ((dayname (unless nodayname (calendar-day-name date abbreviate)))
         (month (extract-calendar-month date))
         (monthname (calendar-month-name month abbreviate))
         (day (int-to-string (extract-calendar-day date)))
         (month (int-to-string month))
         (year (int-to-string (extract-calendar-year date))))

            day year days-remaining (if (= days-remaining 1) "" "s"))))

(defun calendar-print-other-dates ()
  "Show dates on other calendars for date under the cursor."
  (interactive)
  (let ((date (calendar-cursor-to-date t)))
    (with-current-buffer (get-buffer-create other-calendars-buffer)
      (let ((inhibit-read-only t)
            (modified (buffer-modified-p)))
        (calendar-set-mode-line
         (concat (calendar-date-string date) " (Gregorian)"))

(defun calendar-set-mode-line (str)
  "Set mode line to STR, centered, surrounded by dashes."
  (let* ((edges (window-edges))
         ;; As per doc of window-width, total visible mode-line length.
         (width (- (nth 2 edges) (car edges))))
    (setq mode-line-format
          (if buffer-file-name
              `("-" mode-line-modified
                ,(calendar-string-spread (list str) ?- (- width 6))
                "---")