![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cal.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to cal.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 1: ;; Display a calendar inside GNU Emacs.
2: ;; Copyright (C) 1988 Free Software Foundation, Inc.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is free software; you can redistribute it and/or modify
7: ;; it under the terms of the GNU General Public License as published by
8: ;; the Free Software Foundation; either version 1, or (at your option)
9: ;; any later version.
10:
11: ;; GNU Emacs is distributed in the hope that it will be useful,
12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14: ;; GNU General Public License for more details.
15:
16: ;; You should have received a copy of the GNU General Public License
17: ;; along with GNU Emacs; see the file COPYING. If not, write to
18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19: ;;
20: ;; Comments, corrections, and improvements should be sent to
21: ;; Edward M. Reingold Department of Computer Science
22: ;; (217) 333-6733 University of Illinois at Urbana-Champaign
23: ;; [email protected] 1304 West Springfield Avenue
24: ;; Urbana, Illinois 61801
25: ;;
26: ;; The author gratefully acknowledges the patient help of Richard Stallman
27: ;; in making this function into a reasonable piece of code!
28: ;;
29: ;; Modification for month-offset arguments suggested and implemented by
30: ;; Constantine Rasmussen Sun Microsystems, East Coast Division
31: ;; (617) 671-0404 2 Federal Street; Billerica, Ma. 01824
32: ;; ARPA: [email protected] USENET: {cbosgd,decvax,hplabs,seismo}!sun!suneast!cdr
33: ;;
34: ;; Modification to mark current day with stars suggested by
35: ;; Franklin Davis Thinking Machines Corp
36: ;; (617) 876-1111 245 First Street, Cambridge, MA 02142
37: ;; [email protected]
38:
39: (defvar calendar-hook nil
40: "List of functions called after the calendar buffer has been prepared with
41: the calendar of the current month. This can be used, for example, to highlight
42: today's date with asterisks--a function star-date is included for this purpose.
43: The variable offset-calendar-hook is the list of functions called when the
44: calendar function was called for a past or future month.")
45:
46: (defvar offset-calendar-hook nil
47: "List of functions called after the calendar buffer has been prepared with
48: the calendar of a past or future month. The variable calendar-hook is the
49: list of functions called when the calendar function was called for the
50: current month.")
51:
52: (defun calendar (&optional month-offset)
53: "Display three-month calendar in another window.
54: The three months appear side by side, with the current month in the middle
55: surrounded by the previous and next months. The cursor is put on today's date.
56:
57: An optional prefix argument ARG causes the calendar displayed to be
58: ARG months in the future if ARG is positive or in the past if ARG is
59: negative; in this case the cursor goes on the first day of the month.
60:
61: The Gregorian calendar is assumed.
62:
63: After preparing the calendar window, the hooks calendar-hook are run
64: when the calendar is for the current month--that is, the was no prefix
65: argument. If the calendar is for a future or past month--that is, there
66: was a prefix argument--the hooks offset-calendar-hook are run. Thus, for
67: example, setting calendar-hooks to 'star-date will cause today's date to be
68: replaced by asterisks to highlight it in the window."
69: (interactive "P")
70: (if month-offset (setq month-offset (prefix-numeric-value month-offset)))
71: (let ((today (make-marker)))
72: (save-excursion
73: (set-buffer (get-buffer-create "*Calendar*"))
74: (setq buffer-read-only t)
75: (let*
76: ((buffer-read-only nil)
77: ;; Get today's date and extract the day, month and year.
78: (date (current-time-string))
79: (garbage (string-match
80: " \\([A-Z][a-z][a-z]\\) *\\([0-9]*\\) .* \\([0-9]*\\)$"
81: date))
82: (day (or (and month-offset 1)
83: (string-to-int
84: (substring date (match-beginning 2) (match-end 2)))))
85: (month
86: (cdr (assoc
87: (substring date (match-beginning 1) (match-end 1))
88: '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4)
89: ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8)
90: ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
91: (year (string-to-int
92: (substring date (match-beginning 3) (match-end 3)))))
93: (erase-buffer)
94: ;; If user requested a month in the future or the past,
95: ;; advance the variables MONTH and YEAR to describe that one.
96: (cond
97: (month-offset
98: (let ((year-month (+ (+ (* year 12) (- month 1)) month-offset)))
99: (setq month (+ (% year-month 12) 1))
100: (setq year (/ year-month 12)))))
101: ;; Generate previous month, starting at left margin.
102: (generate-month;; previous month
103: (if (= month 1) 12 (1- month))
104: (if (= month 1) (1- year) year)
105: 0)
106: ;; Generate this month, starting at column 24,
107: ;; and record where today's date appears, in the marker TODAY.
108: (goto-char (point-min))
109: (set-marker today (generate-month month year 24 day))
110: ;; Generate the following month, starting at column 48.
111: (goto-char (point-min))
112: (generate-month
113: (if (= month 12) 1 (1+ month))
114: (if (= month 12) (1+ year) year)
115: 48)))
116: ;; Display the buffer and put cursor on today's date.
117: ;; Do it in another window, but if this buffer is already visible,
118: ;; just select its window.
119: (pop-to-buffer "*Calendar*")
120: (goto-char (marker-position today))
121: ;; Make TODAY point nowhere so it won't slow down buffer editing until GC.
122: (set-marker today nil))
123: ;; Make the window just tall enough for its contents.
124: (let ((h (1- (window-height)))
125: (l (count-lines (point-min) (point-max))))
126: (or (= (+ (window-height (selected-window))
127: (window-height (minibuffer-window)))
128: (screen-height))
129: (<= h l)
130: (shrink-window (- h l))))
131: (if month-offset
132: (run-hooks 'offset-calendar-hook)
133: (run-hooks 'calendar-hook)))
134:
135: (defun leap-year-p (year)
136: "Returns true if YEAR is a Gregorian leap year, and false if not."
137: (or
138: (and (= (% year 4) 0)
139: (/= (% year 100) 0))
140: (= (% year 400) 0)))
141:
142: (defun day-number (month day year)
143: "Return day-number within year (origin-1) of the date MONTH DAY YEAR.
144: For example, (day-number 1 1 1987) returns the value 1,
145: while (day-number 12 31 1980) returns 366."
146: ;;
147: ;; an explanation of the calculation can be found in PascAlgorithms by
148: ;; Edward and Ruth Reingold, Scott-foresman/Little, Brown, 1988.
149: ;;
150: (let ((day-of-year (+ day (* 31 (1- month)))))
151: (if (> month 2)
152: (progn
153: (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
154: (if (leap-year-p year)
155: (setq day-of-year (1+ day-of-year)))))
156: day-of-year))
157:
158: (defun day-of-week (month day year)
159: "Returns the day-of-the-week index of MONTH DAY, YEAR.
160: Value is 0 for Sunday, 1 for Monday, etc."
161: ;;
162: ;; Done by calculating the number of days elapsed since the (imaginary)
163: ;; Gregorian date Sunday, December 31, 1 BC and taking that number mod 7.
164: ;;
165: (%
166: (-
167: (+ (day-number month day year)
168: (* 365 (1- year))
169: (/ (1- year) 4))
170: (let ((correction (* (/ (1- year) 100) 3)))
171: (if (= (% correction 4) 0)
172: (/ correction 4)
173: (1+ (/ correction 4)))))
174: 7))
175:
176: (defun generate-month (month year indent &optional day)
177: "Produce a calendar for MONTH, YEAR on the Gregorian calendar, inserted
178: in the buffer starting at the line on which point is currently located, but
179: indented INDENT spaces. The position in the buffer of the optional
180: parameter DAY is returned. The indentation is done from the first
181: character on the line and does not disturb the first INDENT characters on
182: the line."
183: (let* ((first-day-of-month (day-of-week month 1 year))
184: (first-saturday (- 7 first-day-of-month))
185: (last-of-month
186: (if (and (leap-year-p year) (= month 2))
187: 29
188: (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
189: (month-name
190: (aref ["January" "February" "March" "April" "May" "June"
191: "July" "August" "September" "October" "November" "December"]
192: (1- month))))
193: (insert-indented (format " %s %d" month-name year) indent t)
194: (insert-indented " S M Tu W Th F S" indent t)
195: (insert-indented "" indent);; move point to appropriate spot on line
196: (let ((i 0)) ;; add blank days before the first of the month
197: (while (<= (setq i (1+ i)) first-day-of-month)
198: (insert " ")))
199: (let ((i 0)
200: (day-marker)) ;; put in the days of the month
201: (while (<= (setq i (1+ i)) last-of-month)
202: (insert (format "%2d " i))
203: (and
204: day
205: (= i day) ;; save the location of the specified day
206: (setq day-marker (- (point) 2)))
207: (and (= (% i 7) (% first-saturday 7))
208: (/= i last-of-month)
209: (insert-indented "" 0 t) ;; force onto following line
210: (insert-indented "" indent))) ;; go to proper spot on line
211: day-marker)))
212:
213: (defun insert-indented (string indent &optional newline)
214: "Insert STRING at column INDENT.
215: If the optional parameter NEWLINE is true, leave point at start of next
216: line, inserting a newline if there was no next line; otherwise, leave point
217: after the inserted text. Value is always `t'."
218: ;; Try to move to that column.
219: (move-to-column indent)
220: ;; If line is too short, indent out to that column.
221: (if (< (current-column) indent)
222: (indent-to indent))
223: (insert string)
224: ;; Advance to next line, if requested.
225: (if newline
226: (progn
227: (end-of-line)
228: (if (eobp)
229: (newline)
230: (forward-line 1))))
231: t)
232:
233: (defun star-date ()
234: "Replace today's date with asterisks in the calendar window.
235: This function can be used with the calendar-hook run after the
236: calendar window has been prepared."
237: (let ((buffer-read-only nil))
238: (forward-char 1)
239: (delete-backward-char 2)
240: (insert "**")
241: (backward-char 1)))
242:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.