241 lines
9.8 KiB
EmacsLisp
241 lines
9.8 KiB
EmacsLisp
;; Record version number of Emacs.
|
|
;; Copyright (C) 1988 Free Software Foundation, Inc.
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 1, or (at your option)
|
|
;; any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
;;
|
|
;; 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
|
|
|
|
(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 (&optional month-offset)
|
|
"Display 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.
|
|
|
|
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.
|
|
|
|
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")
|
|
(if month-offset (setq month-offset (prefix-numeric-value month-offset)))
|
|
(let ((today (make-marker)))
|
|
(save-excursion
|
|
(set-buffer (get-buffer-create "*Calendar*"))
|
|
(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]\\) *\\([0-9]*\\) .* \\([0-9]*\\)$"
|
|
date))
|
|
(day (or (and month-offset 1)
|
|
(string-to-int
|
|
(substring date (match-beginning 2) (match-end 2)))))
|
|
(month
|
|
(cdr (assoc
|
|
(substring date (match-beginning 1) (match-end 1))
|
|
'(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4)
|
|
("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8)
|
|
("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
|
|
(year (string-to-int
|
|
(substring date (match-beginning 3) (match-end 3)))))
|
|
(erase-buffer)
|
|
;; 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 (+ (+ (* year 12) (- month 1)) month-offset)))
|
|
(setq month (+ (% year-month 12) 1))
|
|
(setq year (/ year-month 12)))))
|
|
;; Generate previous month, starting at left margin.
|
|
(generate-month;; previous month
|
|
(if (= month 1) 12 (1- month))
|
|
(if (= month 1) (1- year) year)
|
|
0)
|
|
;; Generate this month, starting at column 24,
|
|
;; and record where today's date appears, in the marker TODAY.
|
|
(goto-char (point-min))
|
|
(set-marker today (generate-month month year 24 day))
|
|
;; Generate the following month, starting at column 48.
|
|
(goto-char (point-min))
|
|
(generate-month
|
|
(if (= month 12) 1 (1+ month))
|
|
(if (= month 12) (1+ year) 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))
|
|
;; Make TODAY point nowhere so it won't slow down buffer editing until GC.
|
|
(set-marker today nil))
|
|
;; 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)
|
|
(<= h l)
|
|
(shrink-window (- h l))))
|
|
(if month-offset
|
|
(run-hooks 'offset-calendar-hook)
|
|
(run-hooks 'calendar-hook)))
|
|
|
|
(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))))
|
|
(insert-indented (format " %s %d" month-name year) 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))
|
|
(/= 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)))
|
|
|