-;;; calendar.el --- Calendar functions.
+;;; calendar.el --- calendar functions
-;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997,
+;; 2000, 2001 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Keywords: calendar
;; lunar.el Phases of the moon
;; solar.el Sunrise/sunset, equinoxes/solstices
-;; Comments, corrections, and improvements should be sent to
-;; Edward M. Reingold Department of Computer Science
-;; (217) 333-6733 University of Illinois at Urbana-Champaign
-;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
-;; Urbana, Illinois 61801
-
;; Technical details of all the calendrical calculations can be found in
+;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
+;; Cambridge University Press (1997).
+;; An earlier version of the technical details appeared in
;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical
;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and
;; the message BODY containing your mailing address (snail).
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+
;;; Code:
+(eval-when-compile
+ (defvar displayed-month)
+ (defvar displayed-year)
+ (defvar calendar-month-name-array)
+ (defvar calendar-starred-day))
+
(defun calendar-version ()
(interactive)
(message "Version 6, October 12, 1995"))
;;;###autoload
(defcustom number-of-diary-entries 1
"*Specifies how many days of diary entries are to be displayed initially.
-This variable affects the diary display when the command M-x diary is used,
+This variable affects the diary display when the command \\[diary] is used,
or if the value of the variable `view-diary-entries-initially' is t. For
example, if the default value 1 is used, then only the current day's diary
entries will be displayed. If the value 2 is used, then both the current
:type 'boolean
:group 'diary)
+;;;###autoload
+(defcustom calendar-remove-frame-by-deleting nil
+ "*Determine how the calendar mode removes a frame no longer needed.
+If nil, make an icon of the frame. If non-nil, delete the frame."
+ :type 'boolean
+ :group 'view)
+
+(add-to-list 'facemenu-unlisted-faces 'diary-face)
+(defface diary-face
+ '((((class color) (background light))
+ :foreground "red")
+ (((class color) (background dark))
+ :foreground "yellow")
+ (t
+ :bold t))
+ "Face for highlighting diary entries."
+ :group 'diary)
+
+(add-to-list 'facemenu-unlisted-faces 'calendar-today-face)
+(defface calendar-today-face
+ '((t (:underline t)))
+ "Face for indicating today's date."
+ :group 'diary)
+
+(add-to-list 'facemenu-unlisted-faces 'holiday-face)
+(defface holiday-face
+ '((((class color) (background light))
+ :background "pink")
+ (((class color) (background dark))
+ :background "chocolate4")
+ (t
+ :inverse-video t))
+ "Face for indicating dates that have holidays."
+ :group 'diary)
+
(defcustom diary-entry-marker
- (if (not window-system)
+ (if (not (display-color-p))
"+"
- (require 'faces)
- (add-to-list 'facemenu-unlisted-faces 'diary-face)
- (make-face 'diary-face)
- (cond ((face-differs-from-default-p 'diary-face))
- ((x-display-color-p) (set-face-foreground 'diary-face "red"))
- (t (copy-face 'bold 'diary-face)))
'diary-face)
- "*Used to mark dates that have diary entries.
-Can be either a single-character string or a face."
+ "*How to mark dates that have diary entries.
+The value can be either a single-character string or a face."
:type '(choice string face)
:group 'diary)
(defcustom calendar-today-marker
- (if (not window-system)
+ (if (not (display-color-p))
"="
- (require 'faces)
- (add-to-list 'facemenu-unlisted-faces 'calendar-today-face)
- (make-face 'calendar-today-face)
- (if (not (face-differs-from-default-p 'calendar-today-face))
- (set-face-underline-p 'calendar-today-face t))
'calendar-today-face)
- "*Used to mark today's date.
-Can be either a single-character string or a face."
+ "*How to mark today's date in the calendar.
+The value can be either a single-character string or a face.
+Marking today's date is done only if you set up `today-visible-calendar-hook'
+to request that."
:type '(choice string face)
:group 'calendar)
(defcustom calendar-holiday-marker
- (if (not window-system)
+ (if (not (display-color-p))
"*"
- (require 'faces)
- (add-to-list 'facemenu-unlisted-faces 'holiday-face)
- (make-face 'holiday-face)
- (cond ((face-differs-from-default-p 'holiday-face))
- ((x-display-color-p) (set-face-background 'holiday-face "pink"))
- (t (set-face-background 'holiday-face "black")
- (set-face-foreground 'holiday-face "white")))
'holiday-face)
- "*Used to mark notable dates in the calendar.
-Can be either a single-character string or a face."
+ "*How to mark notable dates in the calendar.
+The value can be either a single-character string or a face."
:type '(choice string face)
:group 'calendar)
:type 'hook
:group 'calendar-hooks)
+;;;###autoload
+(defcustom calendar-move-hook nil
+ "*List of functions called whenever the cursor moves in the calendar.
+
+For example,
+
+ (add-hook 'calendar-move-hook (lambda () (view-diary-entries 1)))
+
+redisplays the diary for whatever date the cursor is moved to."
+ :type 'hook
+ :group 'calendar-hooks)
+
;;;###autoload
(defcustom diary-file "~/diary"
"*Name of the file in which one's personal diary of dates is kept.
;;;###autoload
(defcustom sexp-diary-entry-symbol "%%"
- "*The string used to indicate a sexp diary entry in diary-file.
+ "*The string used to indicate a sexp diary entry in `diary-file'.
See the documentation for the function `list-sexp-diary-entries'."
:type 'string
:group 'diary)
(defcustom european-date-diary-pattern
'((day "/" month "[^/0-9]")
(day "/" month "/" year "[^0-9]")
- (backup day " *" monthname "\\W+\\<[^*0-9]")
+ (backup day " *" monthname "\\W+\\<\\([^*0-9]\\|\\([0-9]+[:aApP]\\)\\)")
(day " *" monthname " *" year "[^0-9]")
(dayname "\\W"))
"*List of pseudo-patterns describing the European patterns of date used.
"*List of functions called after marking diary entries in the calendar.
A function `mark-included-diary-files' is also provided for use as the
-mark-diary-entries-hook; it enables you to use shared diary files together
+`mark-diary-entries-hook'; it enables you to use shared diary files together
with your own. The files included are specified in the diary file by lines
of the form
#include \"filename\"
;;;###autoload
(defcustom diary-list-include-blanks nil
"*If nil, do not include days with no diary entry in the list of diary entries.
-Such days will then not be shown in the the fancy diary buffer, even if they
+Such days will then not be shown in the fancy diary buffer, even if they
are holidays."
:type 'boolean
:group 'diary)
(defcustom general-holidays
'((holiday-fixed 1 1 "New Year's Day")
(holiday-float 1 1 3 "Martin Luther King Day")
- (holiday-fixed 2 2 "Ground Hog Day")
+ (holiday-fixed 2 2 "Groundhog Day")
(holiday-fixed 2 14 "Valentine's Day")
(holiday-float 2 1 3 "President's Day")
(holiday-fixed 3 17 "St. Patrick's Day")
(append general-holidays local-holidays other-holidays
christian-holidays hebrew-holidays islamic-holidays
oriental-holidays solar-holidays)
- "*List of notable days for the command M-x holidays.
+ "*List of notable days for the command \\[holidays].
Additional holidays are easy to add to the list, just put them in the list
`other-holidays' in your .emacs file. Similarly, by setting any of
(holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in
MONTH on the Gregorian calendar (0 for Sunday,
etc.); K<0 means count back from the end of the
- month. An optional parameter DAY means the Kth
+ month. An optional parameter DAY means the Kth
DAYNAME after/before MONTH DAY.
(holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar
(holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar
(defconst fancy-diary-buffer "*Fancy Diary Entries*"
"Name of the buffer used for the optional fancy display of the diary.")
+(defconst other-calendars-buffer "*Other Calendars*"
+ "Name of the buffer used for the display of date on other calendars.")
+
(defconst lunar-phases-buffer "*Phases of Moon*"
"Name of the buffer used for the lunar phases.")
(defmacro increment-calendar-month (mon yr n)
"Move the variables MON and YR to the month and year by N months.
Forward if N is positive or backward if N is negative."
- (` (let (( macro-y (+ (* (, yr) 12) (, mon) -1 (, n) )))
- (setq (, mon) (1+ (% macro-y 12) ))
- (setq (, yr) (/ macro-y 12)))))
+ `(let ((macro-y (+ (* ,yr 12) ,mon -1 ,n)))
+ (setq ,mon (1+ (% macro-y 12)))
+ (setq ,yr (/ macro-y 12))))
(defmacro calendar-for-loop (var from init to final do &rest body)
"Execute a for loop."
- (` (let (( (, var) (1- (, init)) ))
- (while (>= (, final) (setq (, var) (1+ (, var))))
- (,@ 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."
- (` (let (( (, index) (, initial))
- (sum 0))
- (while (, condition)
- (setq sum (+ sum (, expression) ))
- (setq (, index) (1+ (, index))))
- sum)))
+ `(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
(car (cdr (cdr date))))
(defsubst calendar-leap-year-p (year)
- "Returns t if YEAR is a Gregorian leap year."
+ "Return t if YEAR is a Gregorian leap year."
(and (zerop (% year 4))
(or (not (zerop (% year 100)))
(zerop (% year 400)))))
(autoload 'calendar-two-frame-setup "cal-x"
"Start calendar and diary in separate, dedicated frames.")
-
+
;;;###autoload
(defvar calendar-setup nil
"The frame set up of the calendar.
The choices are `one-frame' (calendar and diary together in one separate,
-dedicated frame) or `two-frames' (calendar and diary in separate, dedicated
-frames); with any other value the current frame is used.")
+dedicated frame), `two-frames' (calendar and diary in separate, dedicated
+frames), `calendar-only' (calendar in a separate, dedicated frame); with
+any other value the current frame is used.")
;;;###autoload
(defun calendar (&optional arg)
(interactive "P")
(cond ((equal calendar-setup 'one-frame) (calendar-one-frame-setup arg))
((equal calendar-setup 'two-frames) (calendar-two-frame-setup arg))
+ ((equal calendar-setup 'calendar-only)
+ (calendar-only-one-frame-setup arg))
(t (calendar-basic-setup arg))))
(defun calendar-basic-setup (&optional arg)
`number-of-diary-entries' controls the number of days of diary entries
displayed upon initial display of the calendar.
-An optional prefix argument ARG causes the calendar displayed to be ARG
-months in the future if ARG is positive or in the past if ARG is negative;
-in this case the cursor goes on the first day of the month.
-
Once in the calendar window, future or past months can be moved into view.
Arbitrary months can be displayed, or the calendar can be scrolled forward
or backward.
Diary entries can be marked on the calendar or displayed in another window.
-Use M-x describe-mode for details of the key bindings in the calendar window.
+Use \\[describe-mode] for details of the key bindings in the calendar window.
The Gregorian calendar is assumed.
"String of Chinese date of Gregorian date."
t)
-(autoload 'calendar-absolute-from-astro
+(autoload 'calendar-absolute-from-astro "cal-julian"
"Absolute date of astronomical (Julian) day number D."
- "cal-julian")
+ t )
(autoload 'calendar-astro-from-absolute "cal-julian"
"Astronomical (Julian) day number of absolute date D.")
"String of astronomical (Julian) day number of Gregorian date."
t)
-(autoload 'calendar-goto-astro-date "cal-julian"
+(autoload 'calendar-goto-astro-day-number "cal-julian"
"Move cursor to astronomical (Julian) day number."
t)
+(autoload 'calendar-print-astro-day-number "cal-julian"
+ "Show the astro date equivalents of date."
+ t)
+
(autoload 'calendar-julian-from-absolute "cal-julian"
"Compute the Julian (month day year) corresponding to the absolute DATE.
The absolute date is the number of days elapsed since the (imaginary)
"Move cursor to Julian DATE; echo Julian date unless NOECHO is t."
t)
+(autoload 'calendar-print-julian-date "cal-julian"
+ "Show the Julian calendar equivalent of the date under the cursor."
+ t)
+
(autoload 'calendar-julian-date-string "cal-julian"
"String of Julian date of Gregorian DATE.
Defaults to today's date if DATE is not given.
-Driven by the variable `calendar-date-display-form'."
- t)
+Driven by the variable `calendar-date-display-form'.")
(autoload 'calendar-goto-iso-date "cal-iso"
"Move cursor to ISO date."
"String of ISO date of Gregorian date."
t)
+(autoload 'calendar-goto-islamic-date "cal-islam"
+ "Move cursor to Islamic date."
+ t)
+
(autoload 'calendar-print-islamic-date "cal-islam"
"Show the Islamic date equivalents of date."
t)
Optional prefix argument specifies number of weeks.
Holidays are included if `cal-tex-holidays' is t.")
-(autoload 'cal-tex-cursor-week2 "cal-tex"
+(autoload 'cal-tex-cursor-week2 "cal-tex"
"Make a buffer with LaTeX commands for a two-page one-week calendar.
It applies to the week that point is in.
Optional prefix argument specifies number of weeks.
(autoload 'cal-tex-cursor-filofax-week "cal-tex"
"One-week-at-a-glance Filofax style calendar for week indicated by cursor.
Optional prefix argument specifies number of weeks.
-Weeks start on Monday.
+Weeks start on Monday.
Diary entries are included if cal-tex-diary is t.
Holidays are included if `cal-tex-holidays' is t.")
+(autoload 'cal-tex-cursor-filofax-daily "cal-tex"
+ "Day-per-page Filofax style calendar for week indicated by cursor.
+Optional prefix argument specifies number of weeks. Weeks start on Monday.
+Diary entries are included if `cal-tex-diary' is t.
+Holidays are included if `cal-tex-holidays' is t.")
+
(autoload 'cal-tex-cursor-year "cal-tex"
"Make a buffer with LaTeX commands for a year's calendar.
Optional prefix argument specifies number of years.")
(calendar-cursor-to-visible-date
(if today-visible today (list displayed-month 1 displayed-year)))
(set-buffer-modified-p nil)
- (or (one-window-p t)
- (/= (frame-width) (window-width))
- (shrink-window (- (window-height) 9)))
+ (if (or (one-window-p t) (/= (frame-width) (window-width)))
+ ;; Don't mess with the window size, but ensure that the first
+ ;; line is fully visible
+ (set-window-vscroll nil 0)
+ ;; Adjust the window to exactly fit the displayed calendar
+ (fit-window-to-buffer))
(sit-for 0)
(and mark-holidays-in-calendar
(mark-calendar-holidays)
(defun generate-calendar (month year)
"Generate a three-month Gregorian calendar centered around MONTH, YEAR."
(if (< (+ month (* 12 (1- year))) 2)
- (error "Months before February, 1 AD are not available."))
+ (error "Months before February, 1 AD are not available"))
(setq displayed-month month)
(setq displayed-year year)
(erase-buffer)
indent t)
(calendar-insert-indented "" indent);; Go to proper spot
(calendar-for-loop i from 0 to 6 do
- (insert (substring (aref calendar-day-name-array
- (mod (+ calendar-week-start-day i) 7))
- 0 2))
+ (insert (calendar-day-name (mod (+ calendar-week-start-day i) 7)
+ 2 t))
(insert " "))
(calendar-insert-indented "" 0 t);; Force onto following line
(calendar-insert-indented "" indent);; Go to proper spot
;; Put in the days of the month
(calendar-for-loop i from 1 to last do
(insert (format "%2d " i))
- (put-text-property (- (point) 3) (1- (point))
- 'mouse-face 'highlight)
+ (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
(defun redraw-calendar ()
"Redraw the calendar display."
(interactive)
- (let ((cursor-date (calendar-cursor-to-date)))
+ (let ((cursor-date (calendar-cursor-to-nearest-date)))
(generate-calendar-window displayed-month displayed-year)
(calendar-cursor-to-visible-date cursor-date)))
(if calendar-mode-map
nil
(setq calendar-mode-map (make-sparse-keymap))
- (if window-system (require 'cal-menu))
+ (require 'cal-menu)
(calendar-for-loop i from 0 to 9 do
(define-key calendar-mode-map (int-to-string i) 'digit-argument))
(let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph
(define-key calendar-mode-map "\e>" 'calendar-end-of-year)
(define-key calendar-mode-map "\C-@" 'calendar-set-mark)
;; Many people are used to typing C-SPC and getting C-@.
- (define-key calendar-mode-map [?\C-\ ] 'calendar-set-mark)
+ (define-key calendar-mode-map [?\C- ] 'calendar-set-mark)
(define-key calendar-mode-map "\C-x\C-x" 'calendar-exchange-point-and-mark)
(define-key calendar-mode-map "\e=" 'calendar-count-days-region)
(define-key calendar-mode-map "gd" 'calendar-goto-date)
(define-key calendar-mode-map "gmnh" 'calendar-next-haab-date)
(define-key calendar-mode-map "gmpt" 'calendar-previous-tzolkin-date)
(define-key calendar-mode-map "gmnt" 'calendar-next-tzolkin-date)
+ (define-key calendar-mode-map "Aa" 'appt-add)
+ (define-key calendar-mode-map "Ad" 'appt-delete)
(define-key calendar-mode-map "S" 'calendar-sunrise-sunset)
(define-key calendar-mode-map "M" 'calendar-phases-of-moon)
(define-key calendar-mode-map " " 'scroll-other-window)
(define-key calendar-mode-map "pi" 'calendar-print-islamic-date)
(define-key calendar-mode-map "pf" 'calendar-print-french-date)
(define-key calendar-mode-map "pm" 'calendar-print-mayan-date)
+ (define-key calendar-mode-map "po" 'calendar-print-other-dates)
(define-key calendar-mode-map "id" 'insert-diary-entry)
(define-key calendar-mode-map "iw" 'insert-weekly-diary-entry)
(define-key calendar-mode-map "im" 'insert-monthly-diary-entry)
(define-key calendar-mode-map "tw2" 'cal-tex-cursor-week2)
(define-key calendar-mode-map "tw3" 'cal-tex-cursor-week-iso)
(define-key calendar-mode-map "tw4" 'cal-tex-cursor-week-monday)
+ (define-key calendar-mode-map "tfd" 'cal-tex-cursor-filofax-daily)
(define-key calendar-mode-map "tfw" 'cal-tex-cursor-filofax-2week)
(define-key calendar-mode-map "tfW" 'cal-tex-cursor-filofax-week)
(define-key calendar-mode-map "tfy" 'cal-tex-cursor-filofax-year)
(defvar calendar-mode-line-format
(list
- (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-left]")
+ (propertize (substitute-command-keys
+ "\\<calendar-mode-map>\\[scroll-calendar-left]")
+ 'help-echo "mouse-2: scroll left"
+ 'keymap (make-mode-line-mouse-map 'mouse-2
+ #'scroll-calendar-left))
"Calendar"
- (substitute-command-keys "\\<calendar-mode-map>\\[calendar-goto-info-node] info/\\[calendar-other-month] other/\\[calendar-goto-today] today")
+ (concat
+ (propertize
+ (substitute-command-keys
+ "\\<calendar-mode-map>\\[calendar-goto-info-node] info")
+ 'help-echo "mouse-2: read Info on Calendar"
+ 'keymap (make-mode-line-mouse-map 'mouse-2 #'calendar-goto-info-node))
+ "/"
+ (propertize
+ (substitute-command-keys
+ "\\<calendar-mode-map>\\[calendar-other-month] other")
+ 'help-echo "mouse-2: choose another month"
+ 'keymap (make-mode-line-mouse-map
+ 'mouse-2
+ (lambda ()
+ (interactive)
+ (call-interactively
+ 'calendar-other-month))))
+ "/"
+ (propertize
+ (substitute-command-keys
+ "\\<calendar-mode-map>\\[calendar-goto-today] today")
+ 'help-echo "mouse-2: go to today's date"
+ 'keymap (make-mode-line-mouse-map 'mouse-2 #'calendar-goto-today)))
'(calendar-date-string (calendar-current-date) t)
- (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-right]"))
+ (propertize (substitute-command-keys
+ "\\<calendar-mode-map>\\[scroll-calendar-right]")
+ 'help-echo "mouse-2: scroll right"
+ 'keymap (make-mode-line-mouse-map
+ 'mouse-2 #'scroll-calendar-right)))
"The mode line of the calendar buffer.")
(defun calendar-goto-info-node ()
(let ((where (save-window-excursion
(Info-find-emacs-command-nodes 'calendar))))
(if (not where)
- (error "Couldn't find documentation for the calendar.")
+ (error "Couldn't find documentation for the calendar")
(let (same-window-buffer-names)
(info))
(Info-find-node (car (car where)) (car (cdr (car where)))))))
(setq buffer-read-only t)
(setq indent-tabs-mode nil)
(update-calendar-mode-line)
+ (make-local-hook 'activate-menubar-hook)
+ (add-hook 'activate-menubar-hook 'cal-menu-update nil t)
(make-local-variable 'calendar-mark-ring)
(make-local-variable 'displayed-month);; Month in middle of window.
(make-local-variable 'displayed-year));; Year in middle of window.
"List of all calendar-related windows."
(let ((calendar-buffers (calendar-buffer-list))
list)
- (walk-windows '(lambda (w)
- (if (memq (window-buffer w) calendar-buffers)
- (setq list (cons w list))))
+ (walk-windows (lambda (w)
+ (if (memq (window-buffer w) calendar-buffers)
+ (setq list (cons w list))))
nil t)
list))
"List of all calendar-related buffers."
(let* ((diary-buffer (get-file-buffer diary-file))
(buffers (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer
- fancy-diary-buffer diary-buffer calendar-buffer))
+ fancy-diary-buffer diary-buffer calendar-buffer
+ other-calendars-buffer))
(buffer-list nil)
b)
(while buffers
"Get out of the calendar window and hide it and related buffers."
(interactive)
(let* ((diary-buffer (get-file-buffer diary-file)))
- (if (and diary-buffer (buffer-modified-p diary-buffer)
- (not
- (yes-or-no-p
- "Diary modified; do you really want to exit the calendar? ")))
- (error)
+ (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
;; calendar-related buffers with other calendar-related buffers
(mapcar (lambda (x)
(let ((buffer (if (window-live-p window) (window-buffer window))))
(if (memq buffer (calendar-buffer-list))
(cond
- ((and window-system
+ ((and (display-multi-frame-p)
(eq 'icon (cdr (assoc 'visibility
(frame-parameters
(window-frame window))))))
nil)
- ((and window-system (window-dedicated-p window))
- (iconify-frame (window-frame window)))
+ ((and (display-multi-frame-p) (window-dedicated-p window))
+ (if calendar-remove-frame-by-deleting
+ (delete-frame (window-frame window))
+ (iconify-frame (window-frame window))))
((not (and (select-window window) (one-window-p window)))
(delete-window window))
(t (set-buffer buffer)
(bury-buffer))))))
(defun calendar-current-date ()
- "Returns the current date in a list (month day year)."
+ "Return the current date in a list (month day year)."
(let ((now (decode-time)))
(list (nth 4 now) (nth 3 now) (nth 5 now))))
(defun calendar-cursor-to-date (&optional error)
- "Returns a list (month day year) of current cursor position.
+ "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))
value))
(defun calendar-read-date (&optional noday)
- "Prompt for Gregorian date. Returns a list (month day year).
+ "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) "
+\(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))
+ (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
- (capitalize
+ (month (cdr (assoc-ignore-case
(completing-read
"Month name: "
(mapcar 'list (append month-array nil))
- nil t))
- (calendar-make-alist month-array 1 'capitalize))))
+ nil t)
+ (calendar-make-alist month-array 1))))
(last (calendar-last-day-of-month month year)))
(if noday
(if (eq noday t)
(list month year))
(list month
(calendar-read (format "Day (1-%d): " last)
- '(lambda (x) (and (< 0 x) (<= x last))))
+ (lambda (x) (and (< 0 x) (<= x last))))
year))))
(defun calendar-interval (mon1 yr1 mon2 yr2)
(+ (* 12 (- yr2 yr1))
(- mon2 mon1)))
-(defun calendar-day-name (date)
- "Returns a string with the name of the day of the week of DATE."
- (aref calendar-day-name-array (calendar-day-of-week date)))
+(defun calendar-day-name (date &optional width absolute)
+ "Return a string with the name of the day of the week of DATE.
+If WIDTH is non-nil, return just the first WIDTH characters of the name.
+If ABSOLUTE is non-nil, then DATE is actually the day-of-the-week
+rather than a date."
+ (let ((string (aref calendar-day-name-array
+ (if absolute date (calendar-day-of-week date)))))
+ (cond ((null width) string)
+ (enable-multibyte-characters (truncate-string-to-width string width))
+ (t (substring string 0 width)))))
(defvar calendar-day-name-array
- ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"])
+ ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
+ "Array of capitalized strings giving, in order, the day names.")
(defvar calendar-month-name-array
["January" "February" "March" "April" "May" "June"
- "July" "August" "September" "October" "November" "December"])
+ "July" "August" "September" "October" "November" "December"]
+ "Array of capitalized strings giving, in order, the month names.")
(defun calendar-make-alist (sequence &optional start-index filter)
"Make an assoc list corresponding to SEQUENCE.
If FILTER is provided, apply it to each item in the list."
(let ((index (if start-index (1- start-index) 0)))
(mapcar
- '(lambda (x)
+ (lambda (x)
(setq index (1+ index))
(cons (if filter (funcall filter x) x)
index))
(append sequence nil))))
-(defun calendar-month-name (month)
- "The name of MONTH."
- (aref calendar-month-name-array (1- month)))
+(defun calendar-month-name (month &optional width)
+ "The name of MONTH.
+If WIDTH is non-nil, return just the first WIDTH characters of the name."
+ (let ((string (aref calendar-month-name-array (1- month))))
+ (if width
+ (let ((i 0) (result "") (pos 0))
+ (while (< i width)
+ (let ((chartext (char-to-string (aref string pos))))
+ (setq pos (+ pos (length chartext)))
+ (setq result (concat result chartext)))
+ (setq i (1+ i)))
+ result)
+ string)))
(defun calendar-day-of-week (date)
- "Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
+ "Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
(% (calendar-absolute-from-gregorian date) 7))
(defun calendar-unmark ()
(redraw-calendar))
(defun calendar-date-is-visible-p (date)
- "Returns t if DATE is legal and is visible in the calendar window."
+ "Return t if DATE is legal and is visible in the calendar window."
(let ((gap (calendar-interval
displayed-month displayed-year
(extract-calendar-month date) (extract-calendar-year date))))
(and (calendar-date-is-legal-p date) (> 2 gap) (< -2 gap))))
(defun calendar-date-is-legal-p (date)
- "Returns t if DATE is a legal date."
+ "Return t if DATE is a legal date."
(let ((month (extract-calendar-month date))
(day (extract-calendar-day date))
(year (extract-calendar-year date)))
(<= 1 year))))
(defun calendar-date-equal (date1 date2)
- "Returns t if the DATE1 and DATE2 are the same."
+ "Return t if the DATE1 and DATE2 are the same."
(and
(= (extract-calendar-month date1) (extract-calendar-month date2))
(= (extract-calendar-day date1) (extract-calendar-day date2))
(defun calendar-star-date ()
"Replace the date under the cursor in the calendar window with asterisks.
-This function can be used with the today-visible-calendar-hook run after the
+This function can be used with the `today-visible-calendar-hook' run after the
calendar window has been prepared."
- (let ((buffer-read-only nil))
- (make-variable-buffer-local 'calendar-starred-day)
+ (let ((inhibit-read-only t))
+ (make-local-variable 'calendar-starred-day)
(forward-char 1)
(setq calendar-starred-day
(string-to-int
(defun calendar-mark-today ()
"Mark the date under the cursor in the calendar window.
The date is marked with calendar-today-marker. This function can be used with
-the today-visible-calendar-hook run after the calendar window has been
+the `today-visible-calendar-hook' run after the calendar window has been
prepared."
(mark-visible-calendar-date
(calendar-cursor-to-date)
calendar-today-marker))
(defun calendar-date-compare (date1 date2)
- "Returns t if DATE1 is before DATE2, nil otherwise.
+ "Return t if DATE1 is before DATE2, nil otherwise.
The actual dates are in the car of DATE1 and DATE2."
(< (calendar-absolute-from-gregorian (car date1))
(calendar-absolute-from-gregorian (car date2))))
(if nodayname
nil
(if abbreviate
- (substring (calendar-day-name date) 0 3)
+ (calendar-day-name date 3)
(calendar-day-name date))))
(month (extract-calendar-month date))
(monthname
(if abbreviate
- (substring
- (calendar-month-name month) 0 3)
+ (calendar-month-name month 3)
(calendar-month-name month)))
(day (int-to-string (extract-calendar-day date)))
(month (int-to-string month))
(mapconcat 'eval calendar-date-display-form "")))
(defun calendar-dayname-on-or-before (dayname date)
- "Returns the absolute date of the DAYNAME on or before absolute DATE.
+ "Return the absolute date of the DAYNAME on or before absolute DATE.
DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
Note: Applying this function to d+6 gives us the DAYNAME on or after an
(format "Day %d of %d; %d day%s remaining in the year"
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)))
+ (save-excursion
+ (set-buffer (get-buffer-create other-calendars-buffer))
+ (setq buffer-read-only nil)
+ (calendar-set-mode-line
+ (concat (calendar-date-string date) " (Gregorian)"))
+ (erase-buffer)
+ (insert
+ (mapconcat 'identity
+ (list (calendar-day-of-year-string date)
+ (format "ISO date: %s" (calendar-iso-date-string date))
+ (format "Julian date: %s"
+ (calendar-julian-date-string date))
+ (format
+ "Astronomical (Julian) day number (at noon UTC): %s.0"
+ (calendar-astro-date-string date))
+ (format "Fixed (RD) date: %s"
+ (calendar-absolute-from-gregorian date))
+ (format "Hebrew date (before sunset): %s"
+ (calendar-hebrew-date-string date))
+ (format "Persian date: %s"
+ (calendar-persian-date-string date))
+ (let ((i (calendar-islamic-date-string date)))
+ (if (not (string-equal i ""))
+ (format "Islamic date (before sunset): %s" i)))
+ (format "Chinese date: %s"
+ (calendar-chinese-date-string date))
+ (let ((c (calendar-coptic-date-string date)))
+ (if (not (string-equal c ""))
+ (format "Coptic date: %s" c)))
+ (let ((e (calendar-ethiopic-date-string date)))
+ (if (not (string-equal e ""))
+ (format "Ethiopic date: %s" e)))
+ (let ((f (calendar-french-date-string date)))
+ (if (not (string-equal f ""))
+ (format "French Revolutionary date: %s" f)))
+ (format "Mayan date: %s"
+ (calendar-mayan-date-string date)))
+ "\n"))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (display-buffer other-calendars-buffer))))
+
(defun calendar-print-day-of-year ()
"Show day number in year/days remaining in year for date under the cursor."
(interactive)