reingold@m.cs.uiuc.edu (01/03/89)
About a year and a half ago, I developed code to put a three-month calendar
in a window; that code eventually became part of the GNU Emacs disribution.
Now, I have enhanced that code considerably so that one can scroll forward
and backward through the months in the window as though it were infinitely
wide to the left and right.
Before I send this code to GNU to replace the original cal.el, I'd like to
get some reactions to it and have others try to break it.
Here it is! Please alert me to any problems or suggested improvements.
reingold@a.cs.uiuc.edu
---------------------------------------------------------------------------
;; Record version number of Emacs.
;; Copyright (C) 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.
;;
;; 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 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
;;
;; Minor corrections made and code added for forward-month and backward-month
;; by E.M.R., January 2, 1989.
;;
(defvar calendar-hook nil
"List of functions called after the calendar buffer has been prepared with
the calendar of the current month. This can be used, for example, to highlight
today's date with asterisks--a function star-date is included for this purpose.
The variable offset-calendar-hook is the list of functions called when the
calendar function was called for a past or future month.")
(defvar offset-calendar-hook nil
"List of functions called after the calendar buffer has been prepared with
the calendar of a past or future month. The variable calendar-hook is the
list of functions called when the calendar function was called for the
current month.")
(defun calendar-help ()
"Give a description of key-bindings in the calendar window."
(interactive)
(message ", backward a month . forward a month c show original month"))
(defun calendar (&optional month-offset)
"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.
Future months can be moved into view with '+'; prior months can be moved into
view with '-'.
An optional prefix argument MONTH-OFFSET causes the calendar displayed to
be MONTH-OFFSET months in the future if MONTH-OFFSET is positive or in the
past if MONTH-OFFSET is negative; in this case the cursor goes on the first
day of the month.
The Gregorian calendar is assumed.
After preparing the calendar window, the hooks calendar-hook are run
when the calendar is for the current month--that is, the was no prefix
argument. If the calendar is for a future or past month--that is, there
was a prefix argument--the hooks offset-calendar-hook are run. Thus, for
example, setting calendar-hooks to 'star-date will cause today's date to be
replaced by asterisks to highlight it in the window."
(interactive "P")
(save-excursion
(condition-case err;; get rid of any previous calendar buffer
(let ((calendar-buffer (get-buffer "*Calendar*")))
(delete-windows-on calendar-buffer)
(kill-buffer calendar-buffer))
(error nil))
(set-buffer (get-buffer-create "*Calendar*"))
(make-local-variable 'truncate-lines)
(make-local-variable 'mode-line-format)
(local-set-key "," 'backward-month)
(local-set-key "." 'forward-month)
(local-set-key "c" 'show-original)
(local-set-key "?" 'calendar-help)
(setq truncate-lines t)
(make-local-variable 'today);; marks today in the calendar window
(make-local-variable 'original-month);; month originally requested
(make-local-variable 'original-year);; year originally requested
(make-local-variable 'displayed-month);; month visible in middle of window
(make-local-variable 'displayed-year);; year visible in middle of window
(make-local-variable 'initial-month);; first month in buffer
(make-local-variable 'initial-year);; year of first month in buffer
(make-local-variable 'final-month);; last month in buffer
(make-local-variable 'final-year);; year of last month in buffer
(setq buffer-read-only t)
(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)))
(printable-date
(concat day-in-the-week ", " month " " day-in-the-month ", " year))
(day (or (and month-offset 1)
(string-to-int day-in-the-month))))
(setq mode-line-format
(format
"---comma--> *Calendar Buffer* Today is %17s <--period---"
printable-date))
(erase-buffer)
(setq displayed-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 displayed-year (string-to-int year))
(setq original-month displayed-month)
(setq original-year displayed-year)
;; If user requested a month in the future or the past,
;; advance the variables MONTH and YEAR to describe that one.
(cond
(month-offset
(let ((year-month
(+ (+ (* displayed-year 12) (- displayed-month 1))
(prefix-numeric-value month-offset))))
(setq displayed-month (+ (% year-month 12) 1))
(setq displayed-year (/ year-month 12)))))
(setq initial-month (if (= displayed-month 1) 12 (1- displayed-month)))
(setq initial-year
(if (= displayed-month 1) (1- displayed-year) displayed-year))
(setq final-month (if (= displayed-month 12) 1 (1+ displayed-month)))
(setq final-year
(if (= displayed-month 12) (1+ displayed-year) displayed-year))
;; Generate previous month, starting at left margin.
(generate-month initial-month initial-year 0)
;; Generate this month, starting at column 24,
;; and record where today's date appears, in the marker TODAY.
(goto-char (point-min))
(setq today (make-marker))
(set-marker today
(generate-month displayed-month displayed-year 24 day))
;; Generate the following month, starting at column 48.
(goto-char (point-min))
(generate-month final-month final-year 48)))
;; 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*")
(goto-char (marker-position today))
(adjust-window-height)
(if month-offset
(run-hooks 'offset-calendar-hook)
(run-hooks 'calendar-hook)))
(defun show-original ()
"Reposition the calendar window so the original month is visible."
(interactive)
(scroll-left
(* 24
(interval displayed-month displayed-year original-month original-year)))
(setq displayed-month original-month)
(setq displayed-year original-year)
(goto-char (marker-position today)))
(defun forward-month (&optional month-offset)
"Advance the displayed calendar window by one month.
An optional prefix argument MONTH-OFFSET causes the calendar to be advanced by
MONTH-OFFSET months if MONTH-OFFSET is positive or to be moved backward if
MONTH-OFFSET is negative."
(interactive "p")
(if (< month-offset 0)
(backward-month (- month-offset))
(save-excursion
(while (>= (setq month-offset (1- month-offset)) 0)
(if (<=
(interval displayed-month displayed-year final-month final-year)
1)
;; generate the next month
(let ((buffer-read-only nil))
(setq final-month (if (= final-month 12) 1 (1+ final-month)))
(setq final-year
(if (= final-month 1) (1+ final-year) final-year))
(goto-char (point-min))
(generate-month
final-month
final-year
(* 24
(interval
initial-month
initial-year
final-month
final-year)))))
(setq
displayed-month
(if (= displayed-month 12) 1 (1+ displayed-month)))
(setq
displayed-year
(if (= displayed-month 1) (1+ displayed-year) displayed-year))
(adjust-window-height)
(scroll-left 24)))))
(defun backward-month (&optional month-offset)
"Move the displayed calendar window backward by one month.
An optional prefix argument MONTH-OFFSET causes the calendar to be move
backward by MONTH-OFFSET months if MONTH-OFFSET is positive or to be
advanced if MONTH-OFFSET is negative."
(interactive "p")
(if (< month-offset 0)
(forward-month (- month-offset))
(save-excursion
(while (>= (setq month-offset (1- month-offset)) 0)
(if (<=
(interval
initial-month initial-year displayed-month displayed-year)
1)
;; generate the previous month
(let ((buffer-read-only nil))
(setq initial-month
(if (= initial-month 1) 12 (1- initial-month)))
(setq initial-year
(if (= initial-month 12) (1- initial-year) initial-year))
;; shift the buffer 4 characters right
(goto-char (point-min))
(insert " ")
(while (not (last-line-p))
(next-line 1)
(beginning-of-line)
(insert " "))
(goto-char (point-min))
(generate-month initial-month initial-year 0)
;; lengthen last line to full width, if needed
(insert
(format
(concat "%" (int-to-string (- 20 (current-column))) "s") ""))
(if (not (last-line-p))
(progn;; pad last line
(next-line 1)
(beginning-of-line)
(insert (format "%20s" ""))))))
(setq
displayed-month
(if (= displayed-month 1) 12 (1- displayed-month)))
(setq
displayed-year
(if (= displayed-month 12) (1- displayed-year) displayed-year))
(adjust-window-height)
(scroll-right 24)))))
(defun last-line-p ()
"Returns true if point is on the last line of the buffer."
(save-excursion
(end-of-line)
(eobp)))
(defun interval (mon1 yr1 mon2 yr2)
"The number of months difference between the two specified months."
(+ (* 12 (- yr2 yr1))
(- mon2 mon1)))
(defun adjust-window-height ()
"Make the window just tall enough for its contents."
(let ((h (1- (window-height)))
(l (count-lines (point-min) (point-max))))
(or (one-window-p t)
(shrink-window (- h l)))))
(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 (month day year)
"Return day-number within year (origin-1) of the date MONTH DAY YEAR.
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 ((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-of-week (month day year)
"Returns the day-of-the-week index of MONTH DAY, YEAR.
Value is 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.
;;
(%
(-
(+ (day-number month day year)
(* 365 (1- year))
(/ (1- year) 4))
(let ((correction (* (/ (1- year) 100) 3)))
(if (= (% correction 4) 0)
(/ correction 4)
(1+ (/ correction 4)))))
7))
(defun generate-month (month year indent &optional day)
"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 position in the buffer of the optional
parameter DAY is returned. 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 month 1 year) 7)
(first-saturday (- 7 first-day-of-month))
(last-of-month
(if (and (leap-year-p year) (= month 2))
29
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
(month-name
(aref ["January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"]
(1- month))))
(let ((title-line (format " %s %d" month-name year)))
(insert-indented
(format
(concat "%" (int-to-string (- 20 (length title-line))) "s") "")
indent)
(insert-indented title-line indent t))
(insert-indented " S M Tu W Th F S" indent t)
(insert-indented "" indent);; move point to appropriate spot on line
(let ((i 0)) ;; add blank days before the first of the month
(while (<= (setq i (1+ i)) first-day-of-month)
(insert " ")))
(let ((i 0)
(day-marker)) ;; put in the days of the month
(while (<= (setq i (1+ i)) last-of-month)
(insert (format "%2d " i))
(and
day
(= i day) ;; save the location of the specified day
(setq day-marker (- (point) 2)))
(and (= (% i 7) (% first-saturday 7))
(not (delete-backward-char 1))
(/= i last-of-month)
(insert-indented "" 0 t) ;; force onto following line
(insert-indented "" indent))) ;; go to proper spot on line
day-marker)))
(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)
(defun star-date ()
"Replace today's date with asterisks in the calendar window.
This function can be used with the calendar-hook run after the
calendar window has been prepared."
(let ((buffer-read-only nil))
(forward-char 1)
(delete-backward-char 2)
(insert "**")
(backward-char 1)))reingold@m.cs.uiuc.edu (01/05/89)
Thanks to all the many folks who responded to my request! A number of bugs
were uncovered and suggestions made. Here is a MUCH improved version that
includes proper marking of the current date in the window (even when it's
not the middle month), friendlier window treatment (i hope!), it's own major
mode so as not to screw up key bindings, and the ability to accept months
and years (directly) for display with the o command.
Again, I'd be grateful to anyone willing to play with it for a while to find
bugs or make suggestions for improvements.
----------------------------------------------------------------------------
;; Record version number of Emacs.
;; 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.
;;
;; 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 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
;;
;; Minor corrections made and code added for an 'infinite' calendar window
;; by E.M.R., January 4, 1989. GNU Emacs users to numerous to list pointed
;; out a variety of problems with an earlier form of the 'infinite' calendar.
;;
(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 highlight today's date with asterisks--a function
star-date is included for this purpose. The 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.")
(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
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.")
(defun calendar-help ()
"Give a description of key-bindings in the calendar window."
(interactive)
(message
". backward a month , forward a month c current month o other month e exit"))
(defun calendar (&optional month-offset)
"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.
Future months can be moved into view with ','; prior months can be moved into
view with '.'.
An optional prefix argument MONTH-OFFSET causes the calendar displayed to
be MONTH-OFFSET months in the future if MONTH-OFFSET is positive or in the
past if MONTH-OFFSET is negative; in this case the cursor goes on the first
day of the month.
The Gregorian calendar is assumed.
After preparing the calendar window, the hooks today-visible-calendar-hook
are run when 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 in the window."
(interactive "P")
(let ((today (make-marker)))
(save-excursion
(set-buffer (get-buffer-create "*Calendar*"))
(calendar-mode)
(setq calendar-entry-configuration (current-window-configuration))
(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
(format
"--period-> Calendar e exit/o other/c current %17s <-comma--"
date-string))
(erase-buffer)
(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-year (string-to-int year))
(setq displayed-month current-month)
(setq displayed-year current-year)
(setq month-offset
(if month-offset
(prefix-numeric-value month-offset)
0))
(increment-month 'displayed-month 'displayed-year month-offset)
(let ((i-month displayed-month)
(i-year displayed-year)
(i -1)
(day (if (and (> 2 month-offset)
(< -2 month-offset))
(string-to-int day-in-the-month)))
(c-month (1+ (interval displayed-month displayed-year
current-month current-year))))
(increment-month 'i-month 'i-year -2)
;; Generate the three-month window.
(while (>= 2 (setq i (1+ i)))
(increment-month 'i-month 'i-year 1)
;; Generate the month--record where today's date appears
;; in the marker TODAY.
(if (= i c-month)
(set-marker today
(generate-month i-month i-year (* 24 i) day))
(generate-month i-month i-year (* 24 i)))))))
;; 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*")
(goto-char (or (marker-position today)
(point-min)))
;; Make TODAY point nowhere so it won't slow down buffer editing until GC.
(set-marker today nil))
(or (one-window-p t)
(shrink-window (- (window-height) 9)))
(if (or (< 2 month-offset)
(> -2 month-offset))
(run-hooks 'today-invisible-calendar-hook)
(run-hooks 'today-visible-calendar-hook)))
(defvar calendar-mode-map nil)
(if calendar-mode-map
nil
(setq calendar-mode-map (make-sparse-keymap))
(define-key calendar-mode-map "." 'backward-month)
(define-key calendar-mode-map "," 'forward-month)
(define-key calendar-mode-map "c" 'show-current-month)
(define-key calendar-mode-map "o" 'show-other-month)
(define-key calendar-mode-map "e" 'exit-calendar)
(define-key calendar-mode-map "?" 'calendar-help))
(defun calendar-mode ()
"A major mode for the calendar window."
(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 'calendar-entry-configuration)
(make-local-variable 'mode-line-format)
(make-local-variable 'current-month) ;; Current month.
(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 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 (+ (+ (* (eval yr) 12) (- (eval mon) 1)) n)))
(set mon (+ (% y 12) 1))
(set yr (/ y 12))))
(defun exit-calendar ()
"Get out of the calendar window and destroy it."
(interactive)
(set-window-configuration calendar-entry-configuration)
(kill-buffer "*Calendar*"))
(defun show-current-month ()
"Reposition the calendar window so the original request is visible."
(interactive)
(calendar))
(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."
(interactive "p")
(calendar (+ arg
(interval current-month current-year
displayed-month displayed-year))))
(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 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 "Unintelligible month/year!"))
(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 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 (month day year)
"Return day-number within year (origin-1) of the date MONTH DAY YEAR.
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 ((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-of-week (month day year)
"Returns the day-of-the-week index of MONTH DAY, YEAR.
Value is 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.
;;
(%
(-
(+ (day-number month day year)
(* 365 (1- year))
(/ (1- year) 4))
(let ((correction (* (/ (1- year) 100) 3)))
(if (= (% correction 4) 0)
(/ correction 4)
(1+ (/ correction 4)))))
7))
(defun generate-month (month year indent &optional day)
"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 position in the buffer of the optional
parameter DAY is returned. The indentation is done from the first
character on the line and does not disturb the first INDENT characters on
the line.
Each month is 7 days wide and 6 weeks high and is followed by 4 spaces."
(let* ((first-day-of-month (day-of-week month 1 year))
(first-saturday (- 7 first-day-of-month))
(last-of-month
(if (and (leap-year-p year) (= month 2))
29
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
(month-name
(aref ["January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"]
(1- month)))
(buffer-read-only nil))
(save-excursion
(goto-char (point-min))
(let ((title-line (format " %s %d" month-name year)))
(insert-indented ;; Force title line to be correct width.
(format
(concat "%" (int-to-string (- 24 (length title-line))) "s") "")
indent)
(insert-indented title-line indent t))
(insert-indented " S M Tu W Th F S " indent t)
(insert-indented "" indent);; Move point to appropriate spot on line.
(let ((i (- first-day-of-month))
(day-marker))
(while (<= (setq i (1+ i)) 42) ;; Put in the days of the month.
(if (and (<= 1 i) (>= last-of-month i))
(insert (format "%2d " i))
(insert " "))
(and day (= i day) ;; Save the location of the specified day.
(setq day-marker (- (point) 2)))
(and (= (% i 7) (% first-saturday 7))
(progn (insert " ") t) ;; Separate from next month.
(insert-indented "" 0 t) ;; Force onto following line.
(insert-indented "" indent))) ;; Go to proper spot on line.
(set-buffer-modified-p nil)
day-marker))))
(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)
(defun star-date ()
"Replace today's date with asterisks in the calendar window.
This function can be used with the calendar-hook run after the
calendar window has been prepared."
(let ((buffer-read-only nil))
(forward-char 1)
(delete-backward-char 2)
(insert "**")
(backward-char 1)))