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