reingold@m.cs.uiuc.edu (01/16/89)
After a lot of work, here is the calendar package, now enhanced with a diary
mechanism that allows you keep a personal diary of entries that can be
displayed in conjunction with the calendar--it's a bit like the Sun calendar,
only better.
The calendar functions are greatly improved too.
As before, I'd welcome any comments and suggestions for polishing this code.
I suggest byte-compiling it before playing with it, otherwise the response
is irritatingly slow; it's pretty good when byte-compiled.
The whole thing is fully described with the '?' command uin the calendar
window.
------------------------cut here and byte-compile------------------------------
;; Calendar and diary functions.
;; Copyright (C) 1988, 1989 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY. No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing. Refer to the GNU Emacs General Public
;; License for full details.
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License. A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities. It should be in a
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;; This collection of functions implements a calendar window and diary. It
;; generates a calendar for the current month, together with the previous and
;; coming months, or for any other three-month period. The calendar can be
;; shifted forward and backward in the window to show months in the past or
;; future; the cursor can move forward and back by days or weeks, making it
;; possible, for instance, to jump to the date a specified days or weeks from
;; the date under the cursor. The user can specify that dates that have
;; corresponding diary entries (in a file that the user specifies) be marked;
;; the diary entries for any date can be viewed in a separate window. The
;; diary can be viewed independently of the calendar.
;; 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@a.cs.uiuc.edu 1304 West Springfield Avenue
;; Urbana, Illinois 61801
;; The author gratefully acknowledges the patient help of Richard Stallman
;; in making this function into a reasonable piece of code!
;; Modification for month-offset arguments suggested and first implemented by
;; Constantine Rasmussen Sun Microsystems, East Coast Division
;; (617) 671-0404 2 Federal Street; Billerica, MA 01824
;; ARPA: cdr@sun.com USENET: {cbosgd,decvax,hplabs,seismo}!sun!suneast!cdr
;; Modification to mark current day with stars suggested by
;; Franklin Davis Thinking Machines Corp
;; (617) 876-1111 245 First Street, Cambridge, MA 02142
;; fad@think.com
;; GNU Emacs users too numerous to list pointed out a variety of problems
;; with earlier forms of the 'infinite' calendar.
;; Modification to allow forward and backward movement by days suggested by
;; Ashwin Ram Department of Computer Science
;; (203) 432-7037 Yale University
;; Box 2158 Yale Station; New Haven, CT 06520
;; ARPA: Ram-Ashwin@cs.yale.edu USENET: yale!Ram-Ashwin BITNET: Ram@yalecs
;; Implementation of mark-diary-entries and view-diary-entries due in part to
;; Michael S. Littman Cognitive Science Research Group
;; (217) 333-6733 Bell Communications Research
;; mlittman@wind.bellcore.com 445 South St. Box 1961 (2L-331)
;; Morristown, NJ 07960-1961
(defvar view-diary-entries-initially nil
"*If t then the diary entries for the current date will be displayed in
another window when the calendar is first displayed, if the current date is
visible. The number of days of diary entries displayed is governed by the
variable number-of-diary-entries.")
(defvar number-of-diary-entries [1 1 1 1 1 1 1]
"*The value indicates how many days of diary entries are to be displayed.
For example, if the default value [1 1 1 1 1 1 1] is used, then only the
current day's diary entries will be displayed. If it's value is [0 2 2 2 2
4 1] then no diary entries will be displayed on Sunday, the current date's
and the next day's diary entries will be displayed Monday through Thursday,
Friday through Monday's entries will be displayed on Friday, while on
Saturday only that day's entries will be displayed.")
(defvar mark-diary-entries-in-calendar nil
"*If t then any dates with diary entries will be marked by the character
diary-entry-marker.")
(defvar diary-entry-marker "+"
"*The symbol used to mark dates that have diary entries.")
(defvar initial-calendar-window-hook nil
"*List of functions to be called when the calendar window is first opened.
The functions invoked are called after the calendar window is opened, but
once opened is never called again. Leaving the calendar with the 'q' command
and reentering it will cause these functions to be called again.")
(defvar today-visible-calendar-hook nil
"*List of functions called after the calendar buffer has been prepared
with the calendar when the current date is visible in the window.
This can be used, for example, to replace today's date with asterisks; a
function star-date is included for this purpose:
(setq today-visible-calendar-hook 'star-date)
It could also be used to mark the current date with '*'; a function is also
provided for this:
(setq today-visible-calendar-hook 'mark-today)
The corresponding variable today-invisible-calendar-hook is the list of
functions called when the calendar function was called when the current
date is not visible in the window.
Other than the use of the provided functions, the changing of any
characters in the calendar buffer by the hooks may cause the failure of the
functions that move by days and weeks.")
(defvar today-invisible-calendar-hook nil
"*List of functions called after the calendar buffer has been prepared
with the calendar when the current date is not visible in the window.
The corresponding variable today-visible-calendar-hook is the list of
functions called when the calendar function was called when the current
date is visible in the window.
Other than the use of the provided functions, the changing of any
characters in the calendar buffer by the hooks may cause the failure of the
functions that move by days and weeks.")
(defvar diary-file "~/diary"
"*Name of the file in which one's personal diary of dates is kept.
The file's entries are lines in the form DAY, MONTH/DAY or MONTH/DAY/YEAR
at the beginning of the line, followed by a nondigit; the remainder of the
line is taken as the diary entry string for that date. MONTH and DAY are
one or two digit numbers, YEAR is a number and must be written in full. If
the date does not contain a year, it is generic and applies to any year; if
it does not contain a year or a month, it applies to any month.
Entries can also be of the form DAYNAME at the beginning of a line,
followed by a nonletter; the day name must be spelled out in full and
capitalized (e.g., Tuesday). DAYNAME entries apply to any date on which is
on that day of the week. Unless mark-weekly-entries is t, DAYNAME entries
are nonmarking--that is, they will not be marked on dates in the calendar
window.
Lines not in one the above formats are ignored. Here are some sample diary
entries:
12/22/1988 Twentieth wedding anniversary!!
1/1 Happy New Year!
10/22 Ruth's birthday.
21: Payday
Tuesday--weekly meeting with grad students at 10am
1/13/1989 Friday the thirteenth!!
Thursday 4pm squash game with Lloyd.
")
(defvar mark-weekly-entries nil
"*If t, DAYNAME diary entries will cause all the dates that are that day of
the week to be marked when the calendar is marked.")
(defconst calendar-buffer "*Calendar*"
"Name of the buffer used for the calendar.")
(defconst diary-buffer "*Diary Entries*"
"Name of the buffer used for the displayed diary entries.")
(defmacro increment-month (mon yr n)
"Move the variables MON and YR to the month and year N months forward
if N is positive or backward if N is negative."
(` (let (( y (+ (+ (* (, yr) 12) (- (, mon) 1)) (, n)) ))
(setq (, mon) (+ (% y 12) 1))
(setq (, yr) (/ y 12)))))
(defmacro for (var from init to final do &rest body)
"Execute a for loop."
(` (let (( (, var) (1- (, init)) ))
(while (>= (, final) (setq (, var) (1+ (, var))))
(,@ body)))))
(defun calendar (&optional arg)
"Display a three-month calendar in another window.
The three months appear side by side, with the current month in the middle
surrounded by the previous and next months. The cursor is put on today's date.
This function is suitable for execution in a .emacs file; appropriate setting
of the variable view-diary-entries-initially will cause the diary entries for
the current date to be displayed in another window. The value of the variable
number-of-diary-entries controls the number of days of diary entries displayed.
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 months can be moved into view with ',';
prior months can be moved into view with '.'. Arbitrary months can be
displayed with 'o' which prompts for the desired month and year. A space
rolls the calendar forward to the next three months; backspace rolls it
backward to the previous three months.
The cursor can be moved forward one day with 'f' and one week with 'n'.
Similarly, 'b' and 'p' move the cursor backward by a one day and one week,
respectively. All of these commands take prefix arguments which, when
negative, cause movement in the opposite direction. For convenience, the
digit keys are automatically prefixes. The window is replotted as necessary
to display the desired date. 'd' causes the diary entries, if any, to be
displayed in another window.
'q' exits from the calendar, causing the calendar windows and buffers to be
deleted.
The Gregorian calendar is assumed.
After preparing the calendar window initially, the hooks
initial-calendar-window-hook are run.
The hooks today-visible-calendar-hook are run everytime the calendar window
gets shifted, if the current date is visible in the window. If it is not
visible, the hooks today-invisible-calendar-hook are run. Thus, for
example, setting today-visible-calendar-hook to 'star-date will cause
today's date to be replaced by asterisks to highlight it whenever it is
in the window.
Other than the use of provided functions, the changing of any characters in
the calendar buffer by the hooks may cause the failure of the functions
that move by days and weeks."
(interactive "P")
(setq arg (if arg (prefix-numeric-value arg) 0))
(regenerate-calendar-window arg)
(let ((date (list current-month current-day current-year)))
(if (and view-diary-entries-initially
(date-is-visible-p date))
(view-diary-entries
(aref number-of-diary-entries (day-of-week date)))))
(run-hooks 'initial-calendar-window-hook))
(defun diary ()
"Generate the diary window for the current date.
The number of days of diary entries is governed by number-of-diary-entries.
This function is suitable for execution in a .emacs file."
(interactive)
(if (and diary-file (file-exists-p diary-file))
(save-excursion
(let* ( ;; Get today's date and extract the day, month and year.
(date (current-time-string))
(garbage (string-match
"^\\([A-Z][a-z]*\\) *\\([A-Z][a-z]*\\) *\\([0-9]*\\) .* \\([0-9]*\\)$"
date))
(month (substring date (match-beginning 2) (match-end 2)))
(month
(cdr (assoc month
'(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4)
("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8)
("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
(day (string-to-int
(substring date (match-beginning 3) (match-end 3))))
(year (string-to-int
(substring date (match-beginning 4) (match-end 4))))
(date (list month day year))
(day-in-week (day-of-week date))
(number-of-days (aref number-of-diary-entries day-in-week)))
(if (< 0 number-of-days)
(progn
(set-buffer (find-file-noselect diary-file t))
(goto-char (point-min))
(list-diary-entries date number-of-days)))))
(error "You don't have a diary file!")))
(defun regenerate-calendar-window (&optional arg)
"Generate the calendar window, offset from the current date by ARG months."
(if (not arg) (setq arg 0))
(save-excursion
(set-buffer (get-buffer-create calendar-buffer))
(calendar-mode)
(let* ((buffer-read-only nil)
;; Get today's date and extract the day, month and year.
(date (current-time-string))
(garbage (string-match
"^\\([A-Z][a-z]*\\) *\\([A-Z][a-z]*\\) *\\([0-9]*\\) .* \\([0-9]*\\)$"
date))
(day-in-the-week
(substring date (match-beginning 1) (match-end 1)))
(month (substring date (match-beginning 2) (match-end 2)))
(day-in-the-month
(substring date (match-beginning 3) (match-end 3)))
(year (substring date (match-beginning 4) (match-end 4)))
(date-string
(concat day-in-the-week ", "
month " " day-in-the-month ", " year)))
(setq mode-line-format
(concat
(format
"--period-> Calendar h help/o other/c current %17s <-comma"
date-string)
"%-"))
(setq current-month
(cdr (assoc month
'(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4)
("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8)
("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
(setq current-day (string-to-int day-in-the-month))
(setq current-year (string-to-int year))
(let ((d-month current-month)
(d-year current-year))
(increment-month d-month d-year arg)
(generate-calendar d-month d-year))))
;; Display the buffer and put cursor on today's date. Do it in another
;; window, but if this buffer is already visible, just select its window.
(pop-to-buffer calendar-buffer)
(if mark-diary-entries-in-calendar
(mark-diary-entries))
(set-buffer-modified-p nil)
(or (one-window-p t)
(shrink-window (- (window-height) 9)))
(if (and (<= arg 1) (>= arg -1))
(progn;; When the current date is on the screen.
(goto-visible-date (list current-month current-day current-year))
(run-hooks 'today-visible-calendar-hook))
(progn;; When the current date is not on the screen.
(goto-char (point-min))
(run-hooks 'today-invisible-calendar-hook))))
(defun generate-calendar (month year)
"Generate a three-month Gregorian calendar centered around MONTH, YEAR."
(if (< (+ d-month (* 12 (1- d-year))) 2)
(error "Months before February, 1 AD are not available."))
(setq displayed-month month)
(setq displayed-year year)
(erase-buffer)
(increment-month month year -1)
(for i from 0 to 2 do
(generate-month month year (+ 5 (* 25 i)))
(increment-month month year 1)))
(defun generate-month (month year indent)
"Produce a calendar for MONTH, YEAR on the Gregorian calendar, inserted
in the buffer starting at the line on 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* ((first-day-of-month (day-of-week (list month 1 year)))
(first-saturday (- 7 first-day-of-month))
(last (last-day month year)))
(goto-char (point-min))
(insert-indented
(format " %s %d" (month-name month) year) indent t)
(insert-indented " S M Tu W Th F S" indent t)
(insert-indented "" indent);; move point to appropriate spot on line
;; add blank days before the first of the month
(for i from 1 to first-day-of-month do
(insert " "))
;; put in the days of the month
(for i from 1 to last do
(insert (format "%2d " i))
(and (= (% i 7) (% first-saturday 7))
(/= i last)
(insert-indented "" 0 t) ;; force onto following line
(insert-indented "" indent))))) ;; go to proper spot on line
(defun insert-indented (string indent &optional newline)
"Insert STRING at column INDENT.
If the optional parameter NEWLINE is true, leave point at start of next
line, inserting a newline if there was no next line; otherwise, leave point
after the inserted text. Value is always `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))
(insert string)
;; Advance to next line, if requested.
(if newline
(progn
(end-of-line)
(if (eobp)
(newline)
(forward-line 1))))
t)
(defvar calendar-mode-map nil)
(if calendar-mode-map
nil
(setq calendar-mode-map (make-sparse-keymap))
(for i from 0 to 9 do
(define-key calendar-mode-map (int-to-string i) 'digit-argument))
(define-key calendar-mode-map "." 'backward-month)
(define-key calendar-mode-map "\b" 'backward-three-months)
(define-key calendar-mode-map "," 'forward-month)
(define-key calendar-mode-map " " 'forward-three-months)
(define-key calendar-mode-map "c" 'show-current-month)
(define-key calendar-mode-map "o" 'show-other-month)
(define-key calendar-mode-map "q" 'exit-calendar)
(define-key calendar-mode-map "f" 'forward-day)
(define-key calendar-mode-map "b" 'backward-day)
(define-key calendar-mode-map "n" 'next-week)
(define-key calendar-mode-map "p" 'previous-week)
(define-key calendar-mode-map "m" 'mark-diary-entries)
(define-key calendar-mode-map "u" 'unmark-diary-entries)
(define-key calendar-mode-map "d" 'view-diary-entries)
(define-key calendar-mode-map "h" 'calendar-help)
(define-key calendar-mode-map "?" 'describe-mode))
(defun calendar-help ()
"Print a message with a list of all the calendar commands."
(interactive)
(message "Commands: SPC BKS . , c o q f b n p m u d h ? for more details"))
;; Calendar mode is suitable only for specially formatted data.
(put 'calendar-mode 'mode-class 'special)
(defun calendar-mode ()
"A major mode for the sliding calendar window and diary.
The key bindings are \\{calendar-mode-map}
The variable view-diary-entries-initially, whose default is nil, can be set
to to t cause diary entries for the current date will be displayed in
another window when the calendar is first displayed, if the current date is
visible. The number of days of diary entries that will be displayed. For
example, if the default value [1 1 1 1 1 1 1] is used, then only the
current day's diary entries will be displayed. If it's value is [0 2 2 2 2
4 1] then no diary entries will be displayed on Sunday, the current date's
and the next day's diary entries will be displayed Monday through Thursday,
Friday through Monday's entries will be displayed on Friday, while on
Saturday only that day's entries will be displayed.
The variable mark-diary-entries-in-calendar can be set to t to cause any
dates visible with calendar entries to be marked with the symbol
diary-entry-marker, normally a plus sign.
The variable initial-calendar-window-hook, whose default value is nil,
is list of functions to be called when the calendar window is first opened.
The functions invoked are called after the calendar window is opened, but
once opened is never called again. Leaving the calendar with the 'q' command
and reentering it will cause these functions to be called again.
The variable today-visible-calendar-hook, whose default value is nil,
is the list of functions called after the calendar buffer has been prepared
with the calendar when the current date is visible in the window.
This can be used, for example, to replace today's date with asterisks; a
function star-date is included for this purpose:
(setq today-visible-calendar-hook 'star-date)
It could also be used to mark the current date with '*'; a function is also
provided for this:
(setq today-visible-calendar-hook 'mark-today)
The variable today-invisible-calendar-hook, whose default value is nil,
is the list of functions called after the calendar buffer has been prepared
with the calendar when the current date is not visible in the window.
Other than the use of the provided functions, the changing of any
characters in the calendar buffer by the hooks may cause the failure of the
functions that move by days and weeks.
The variable diary-file, whose default value is ~/diary, is name of the
file in which one's personal diary of dates is kept. The file's entries
are lines in the form DAY, MONTH/DAY or MONTH/DAY/YEAR at the beginning of
the line, followed by a nondigit; the remainder of the line is taken as the
diary entry string for that date. MONTH and DAY are one or two digit
numbers, YEAR is a number and must be written in full. If the date does
not contain a year, it is generic and applies to any year; if it does not
contain a year or a month, it applies to any month.
Entries can also be of the form DAYNAME at the beginning of a line,
followed by a nonletter; the day name must be spelled out in full and
capitalized (e.g., Tuesday). DAYNAME entries apply to any date on which is
on that day of the week. Unless mark-weekly-entries is t, DAYNAME entries
are nonmarking--that is, they will not be marked on dates in the calendar
window.
Lines not in one the above formats are ignored. Here are some sample diary
entries:
12/22/1988 Twentieth wedding anniversary!!
1/1 Happy New Year!
10/22 Ruth's birthday.
21: Payday
Tuesday--weekly meeting with grad students at 10am
1/13/1989 Friday the thirteenth!!
Thursday 4pm squash game with Lloyd.
Executing view-diary-entries causes the dairy entries for the date
indicated by the cursor in the calendar window to be displayed in another
window. This function takes an integer argument that specifies the number
of days of calendar entries to be displayed, starting with the date
indicated by the cursor.
The function diary causes the diary entries for the current date to be
displayed, independently of the calendar. The number of days of entries is
governed by number-of-diary-entries.
The Gregorian calendar is assumed."
(kill-all-local-variables)
(setq major-mode 'calendar-mode)
(setq mode-name "Calendar")
(use-local-map calendar-mode-map)
(setq buffer-read-only t)
(make-local-variable 'mode-line-format)
(make-local-variable 'current-month) ;; Current month.
(make-local-variable 'current-day) ;; Current day.
(make-local-variable 'current-year) ;; Current year.
(make-local-variable 'displayed-month);; Month in middle of window.
(make-local-variable 'displayed-year));; Year in middle of window.
(defun exit-calendar ()
"Get out of the calendar window and destroy it and related buffers."
(interactive)
(delete-windows-on (get-buffer calendar-buffer))
(kill-buffer calendar-buffer)
(delete-windows-on (get-buffer-create diary-buffer))
(kill-buffer diary-buffer)
(let ((calendar-buffer (get-file-buffer diary-file)))
(if calendar-buffer
(progn
(delete-windows-on calendar-buffer)
(kill-buffer calendar-buffer)))))
(defun show-current-month ()
"Reposition the calendar window so the current date is visible."
(interactive)
(let ((current-date (list current-month current-day current-year)))
(if (date-is-visible-p current-date)
(goto-visible-date current-date)
(regenerate-calendar-window))))
(defun forward-month (&optional arg)
"Advance the displayed calendar window by one month.
An optional prefix argument ARG causes the calendar to be advanced by
ARG months if ARG is positive or to be moved backward if ARG is negative.
The relative position of the cursor with respect to the calendar is
maintained as well as possible."
(interactive "p")
(let* ((column (current-column))
(new-column (- column (* 25 arg)))
(line (progn
(beginning-of-line)
(1+ (count-lines 1 (point))))))
(regenerate-calendar-window
(+ arg (calendar-interval current-month current-year
displayed-month displayed-year)))
(goto-line line)
(beginning-of-line)
(if (> new-column 75)
(end-of-line)
(if (> new-column 0)
(forward-char new-column)))))
(defun forward-three-months (arg)
"Advance the displayed calendar window by 3*ARG months."
(interactive "p")
(forward-month (* 3 arg))
(let ((current-date (list current-month current-day current-year)))
(if (date-is-visible-p current-date)
(goto-visible-date current-date))))
(defun backward-month (&optional arg)
"Move the displayed calendar window backward by one month.
An optional prefix argument ARG causes the calendar to be move backward
by ARG months if ARG is positive or to be advanced if ARG is negative."
(interactive "p")
(forward-month (- arg)))
(defun backward-three-months (arg)
"Move the displayed calendar window backward by 3*ARG months."
(interactive "p")
(forward-month (* -3 arg))
(let ((current-date (list current-month current-day current-year)))
(if (date-is-visible-p current-date)
(goto-visible-date current-date))))
(defun cursor-to-date ()
"Returns (month day year) of current cursor position, or nil if the cursor
is not on a specific day."
(if (and (looking-at "[*0-9]")
(< 2 (count-lines (point-min) (point))))
(save-excursion
(re-search-backward "[^0-9]")
(forward-char 1)
(let*
((day (string-to-int (buffer-substring (point) (+ 3 (point)))))
(day (if (= 0 day) current-day day));; Starred date.
(segment (/ (current-column) 25))
(month (% (+ displayed-month segment -1) 12))
(month (if (= 0 month) 12 month))
(year
(cond
((and (= 12 month) (= segment 0)) (1- displayed-year))
((and (= 1 month) (= segment 2)) (1+ displayed-year))
(t displayed-year))))
(list month day year)))))
(defun forward-day (&optional arg)
"Move the cursor forward ARG days, changing the calendar window if needed.
Movement is backward if ARG is negative."
(interactive "p")
(let*
((cursor-date (or (cursor-to-date)
(error "Cursor is not on a date!")))
(new-cursor-date
(normal-from-absolute
(+ (absolute-from-normal cursor-date) arg)))
(new-display-month (extract-month new-cursor-date))
(new-display-year (extract-year new-cursor-date)))
;; Put the new month on the screen, if needed, and go to the new date.
(if (not (date-is-visible-p new-cursor-date))
(show-other-month new-display-month new-display-year))
(goto-visible-date new-cursor-date)))
(defun extract-month (date)
"Extract the month part of DATE which has the form (month day year)."
(car date))
(defun extract-day (date)
"Extract the day part of DATE which has the form (month day year)."
(car (cdr date)))
(defun extract-year (date)
"Extract the year part of DATE which has the form (month day year)."
(car (cdr (cdr date))))
(defun normal-from-absolute (date)
"Compute the list (month day year) corresponding to the absolute DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let ((month 1)
(day 0)
(year (/ date 366)))
;; Calculate month, day, and year of DATE.
(while (< (absolute-from-normal (list 12 31 year)) date)
(setq year (1+ year)))
(while (< (absolute-from-normal
(list month (last-day month year) year))
date)
(setq month (1+ month)))
(setq day (- (1+ date) (absolute-from-normal (list month 1 year))))
(list month day year)))
(defun goto-visible-date (date)
"Move the cursor to DATE that is on the screen."
(let* ((month (extract-month date))
(day (extract-day date))
(year (extract-year date))
(gap (calendar-interval displayed-month displayed-year month year))
(line (+ 2
(/ (+ day -1
(day-of-week (list month 1 year)))
7)))
(segment (1+ gap)))
(goto-char (point-min))
(forward-line line)
(forward-char (+ 6
(* 25 segment)
(* 3 (day-of-week date))))))
(defun backward-day (&optional arg)
"Move the cursor back ARG days, changing the calendar window if needed.
Movement is forward if ARG is negative."
(interactive "p")
(forward-day (- arg)))
(defun next-week (&optional arg)
"Move the cursor forward ARG weeks, changing the calendar window if needed.
Movement is backward if ARG is negative."
(interactive "p")
(forward-day (* arg 7)))
(defun previous-week (&optional arg)
"Move the cursor back ARG weeks, changing the calendar window if needed.
Movement is forward if ARG is negative."
(interactive "p")
(forward-day (- (* arg 7))))
(defun show-other-month (month year)
"Display a three-month calendar centered around MONTH and YEAR."
(interactive "nMonth (1-12): \nnYear (>0): ")
(if (or (< 12 month) (> 1 month) (> 1 year))
(error "Unacceptable month/year!"))
(regenerate-calendar-window
(calendar-interval current-month current-year month year)))
(defun last-line-p ()
"Returns true if point is on the last line of the buffer."
(save-excursion
(end-of-line)
(eobp)))
(defun calendar-interval (mon1 yr1 mon2 yr2)
"The number of months difference between the two specified months."
(+ (* 12 (- yr2 yr1))
(- mon2 mon1)))
(defun leap-year-p (year)
"Returns true if YEAR is a Gregorian leap year, and false if not."
(or
(and (= (% year 4) 0)
(/= (% year 100) 0))
(= (% year 400) 0)))
(defun day-number (date)
"Return the day number within the year of the date DATE.
For example, (day-number (1 1 1987)) returns the value 1,
while (day-number (12 31 1980)) returns 366."
;;
;; An explanation of the calculation can be found in PascAlgorithms by
;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988.
;;
(let* ((month (extract-month date))
(day (extract-day date))
(year (extract-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 (leap-year-p year)
(setq day-of-year (1+ day-of-year)))))
day-of-year))
(defun day-name (date)
"Returns a string with the name of the day of the week of DATE."
(aref
["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
(day-of-week date)))
(defun day-of-week (date)
"Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
;;
;; Done by calculating the number of days elapsed since the (imaginary)
;; Gregorian date Sunday, December 31, 1 BC and taking that number mod 7.
;;
(% (absolute-from-normal date) 7))
(defun absolute-from-normal (date)
"Calculates the number of days elapsed since the (imaginary) Gregorian date
Sunday, December 31, 1 BC to DATE."
(let ((month (extract-month date))
(day (extract-day date))
(year (extract-year date)))
(-
(+ (day-number date)
(* 365 (1- year))
(/ (1- year) 4))
(let ((correction (* (/ (1- year) 100) 3)))
(if (= (% correction 4) 0)
(/ correction 4)
(1+ (/ correction 4)))))))
(defun last-day (month year)
"The last day in MONTH during YEAR."
(if (and (leap-year-p year) (= month 2))
29
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
(defun month-name (month)
"The name of MONTH."
(aref ["January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"]
(1- month)))
(defun view-diary-entries (arg)
"Searches the file diary-file for entries that match ARG days starting with
the date indicated by the cursor position in the displayed three-month
calendar. If there is no calendar buffer, one is generated with the cursor
on the current day."
(interactive "p")
(if (and diary-file (file-exists-p diary-file))
(if (< 0 arg)
(let ((cursor-date (or (cursor-to-date)
(error "Cursor is not on a date!"))))
(set-buffer (find-file-noselect diary-file t))
(goto-char (point-min))
(list-diary-entries cursor-date arg)))
(error "You don't have a diary file!")))
(defun list-diary-entries (date number)
"Create a buffer containing the lines in diary-file that apply to DATE and
the next NUMBER-1 days."
(let* ((buffer (current-buffer))
(entry-found-this-date)
(any-entries)
(month (extract-month date))
(day (extract-day date))
(year (extract-year date))
(date-string (format "%s, %s %d, %d"
(day-name date) (month-name month) day year)))
(save-excursion
(for i from 1 to number do
(goto-char (point-min))
(let ((regexp (concat
"\\(^" (int-to-string day) "[^0-9/]\\)"
"\\|\\(^" (int-to-string month) "/" (int-to-string day) "[^0-9/]\\)"
"\\|\\(^" (int-to-string month) "/" (int-to-string day)
"/" (int-to-string year) "[^0-9/]\\)"
"\\|^" (day-name date))))
(while (re-search-forward regexp nil t)
(if (not entry-found-this-date)
(save-excursion;; First entry for this date.
(set-buffer (get-buffer-create diary-buffer))
(setq buffer-read-only nil)
(if (not any-entries);; First entry for the buffer.
(progn
(make-local-variable 'mode-line-format)
(setq mode-line-format
(concat "-------------------Diary entries for " date-string "%-"))
(erase-buffer)
(if (< 1 i)
(insert-string
(concat "No entries for "
date-string ".\n")))))
(if (< 1 i)
(insert-string
(concat
"\n===== "
(cond
((= i 2)
"Tomorrow ===============================\n")
((= i 3) "Day after tomorrow =====================\n")
((< 3 i)
(concat (int-to-string (1- i)) " days from now ========================\n"))))))
(setq entry-found-this-date t)))
(beginning-of-line 1);; Just insert the entry.
(let ((start (point))
(end (progn (forward-line 1) (point))))
(save-excursion
(set-buffer diary-buffer)
(insert-buffer-substring buffer start end))
(forward-char -1))))
(setq date (normal-from-absolute (1+ (absolute-from-normal date))))
(setq month (extract-month date))
(setq day (extract-day date))
(setq year (extract-year date))
(setq any-entries (or any-entries entry-found-this-date))
(setq entry-found-this-date nil))
(if (not any-entries)
(message "No diary entries for %s" date-string ".")
(set-buffer diary-buffer)
(display-buffer diary-buffer)
(setq buffer-read-only t)
(set-buffer-modified-p nil)))))
(defun mark-diary-entries ()
"For each DAY, MONTH/DAY, and MONTH/DAY/YEAR entry in diary-file visible
in the calendar window, mark the day in the calendar window."
(interactive)
(if (and diary-file (file-exists-p diary-file))
(save-excursion
(set-buffer (find-file-noselect diary-file t))
;; For each day name in the diary-file, mark dates with that name.
(if mark-weekly-entries
(for day from 0 to 6 do
(goto-char (point-min))
(if (search-forward
(aref ["Sunday" "Monday" "Tuesday" "Wednesday"
"Thursday" "Friday" "Saturday"]
day)
nil t)
(mark-days-named day))))
(goto-char (point-min))
;; For each date in the diary-file, mark it if it is in range.
(while (re-search-forward "^\\([0-9]+\\)[^0-9]" nil t)
(let ((month (string-to-int
(buffer-substring (match-beginning 1) (match-end 1))))
(day 0)
(year 0))
(if (looking-at "[0-9]")
(progn
(re-search-forward "\\([0-9]+\\)[^0-9]" nil t)
(setq day (string-to-int
(buffer-substring (match-beginning 1)
(match-end 1)))))
(setq day month);; It's a DAY entry, not a MONTH.
(setq month 0))
(if (looking-at "[0-9]")
(progn
(re-search-forward "\\([0-9]+\\)[^0-9]" nil t)
(setq year (string-to-int
(buffer-substring (match-beginning 1)
(match-end 1))))))
(mark-date-pattern month day year))))
(error "You don't have a diary file!")))
(defun mark-days-named (dayname)
"Mark all dates in the calendar window that are day DAYNAME of the week.
0 means all Sundays, 1 means all Mondays, and so on."
(save-excursion
(set-buffer calendar-buffer)
(let ((prev-month displayed-month)
(prev-year displayed-year)
(succ-month displayed-month)
(succ-year displayed-year)
(first-date)
(last-date)
(day))
(increment-month succ-month succ-year 1)
(increment-month prev-month prev-year -1)
(setq first-date (list prev-month 1 prev-year))
(setq last-day
(absolute-from-normal
(list succ-month (last-day succ-month succ-year) succ-year)))
(setq day (+ (absolute-from-normal first-date)
7
dayname
(- (day-of-week first-date))))
(while (<= day last-day)
(mark-visible-date (normal-from-absolute day))
(setq day (+ day 7))))))
(defun mark-date-pattern (month day year)
"Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
A value of 0 is a wild-card."
(save-excursion
(set-buffer calendar-buffer)
(let ((prev-month displayed-month)
(prev-year displayed-year)
(succ-month displayed-month)
(succ-year displayed-year))
(increment-month succ-month succ-year 1)
(increment-month prev-month prev-year -1)
(if (or (= month prev-month) (= month 0))
(if (= year 0)
(mark-visible-date (list prev-month day prev-year))
(if (= year displayed-year)
(mark-visible-date (list month day displayed-year)))))
(if (or (= month succ-month) (= month 0))
(if (= year 0)
(mark-visible-date (list succ-month day succ-year))
(if (= year displayed-year)
(mark-visible-date (list month day displayed-year)))))
(if (and (or (= month displayed-month) (= month 0))
(or (= year 0) (= year displayed-year)))
(mark-visible-date (list displayed-month day displayed-year))))))
(defun unmark-diary-entries ()
"Delete the diary entry marks in the calendar."
(interactive)
(let ((position (point))
(buffer-read-only nil))
(goto-char (point-min))
(forward-line 2)
(replace-string diary-entry-marker " ")
(goto-char position)))
(defun date-is-visible-p (date)
"Returns true if DATE is visible in the calendar window."
(save-excursion
(set-buffer calendar-buffer)
(let ((gap (calendar-interval displayed-month displayed-year
(extract-month date) (extract-year date))))
(and (date-is-legal-p date) (> 2 gap) (< -2 gap)))))
(defun date-is-legal-p (date)
"Returns true if DATE is a legal date."
(let ((month (extract-month date))
(day (extract-day date))
(year (extract-year date)))
(and (<= 1 month) (<= month 12)
(<= 1 day) (<= day (last-day month year))
(<= 1 year))))
(defun mark-visible-date (date &optional mark)
"Leave mark DATE with MARK. MARK defaults to diary-entry-marker."
(if (date-is-legal-p date)
(save-excursion
(set-buffer calendar-buffer)
(goto-visible-date date)
(forward-char 1)
(let ((buffer-read-only nil))
(delete-char 1)
(insert (if mark mark diary-entry-marker))
(forward-char -2))
(set-buffer-modified-p nil))))
(defun star-date ()
"Replace today's date with asterisks in the calendar window.
This function can be used with the today-visible-calendar-hook run after the
calendar window has been prepared."
(let ((buffer-read-only nil))
(forward-char 1)
(delete-char -2)
(insert "**")
(backward-char 1)
(set-buffer-modified-p nil)))
(defun mark-today ()
"Mark today's date with an asterisk in the calendar window.
This function can be used with the today-visible-calendar-hook run after the
calendar window has been prepared."
(let ((buffer-read-only nil))
(forward-char 1)
(delete-char 1)
(insert "*")
(set-buffer-modified-p nil)))