Mercurial > emacs
comparison lisp/calendar/cal-move.el @ 13053:621d48117fde
Initial revision
author | Edward M. Reingold <reingold@emr.cs.iit.edu> |
---|---|
date | Thu, 21 Sep 1995 03:11:06 +0000 |
parents | |
children | 83f275dcd93a |
comparison
equal
deleted
inserted
replaced
13052:71be832cf34a | 13053:621d48117fde |
---|---|
1 ;;; cal-move.el --- calendar functions for movement in the calendar | |
2 | |
3 ;; Copyright (C) 1995 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> | |
6 ;; Keywords: calendar | |
7 ;; Human-Keywords: calendar | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;; This collection of functions implements movement in the calendar for | |
28 ;; calendar.el. | |
29 | |
30 ;; Comments, corrections, and improvements should be sent to | |
31 ;; Edward M. Reingold Department of Computer Science | |
32 ;; (217) 333-6733 University of Illinois at Urbana-Champaign | |
33 ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue | |
34 ;; Urbana, Illinois 61801 | |
35 | |
36 ;;; Code: | |
37 | |
38 (defun calendar-goto-today () | |
39 "Reposition the calendar window so the current date is visible." | |
40 (interactive) | |
41 (let ((today (calendar-current-date)));; The date might have changed. | |
42 (if (not (calendar-date-is-visible-p today)) | |
43 (generate-calendar-window) | |
44 (update-calendar-mode-line) | |
45 (calendar-cursor-to-visible-date today)))) | |
46 | |
47 (defun calendar-forward-month (arg) | |
48 "Move the cursor forward ARG months. | |
49 Movement is backward if ARG is negative." | |
50 (interactive "p") | |
51 (calendar-cursor-to-nearest-date) | |
52 (let* ((cursor-date (calendar-cursor-to-date t)) | |
53 (month (extract-calendar-month cursor-date)) | |
54 (day (extract-calendar-day cursor-date)) | |
55 (year (extract-calendar-year cursor-date))) | |
56 (increment-calendar-month month year arg) | |
57 (let ((last (calendar-last-day-of-month month year))) | |
58 (if (< last day) | |
59 (setq day last))) | |
60 ;; Put the new month on the screen, if needed, and go to the new date. | |
61 (let ((new-cursor-date (list month day year))) | |
62 (if (not (calendar-date-is-visible-p new-cursor-date)) | |
63 (calendar-other-month month year)) | |
64 (calendar-cursor-to-visible-date new-cursor-date)))) | |
65 | |
66 (defun calendar-forward-year (arg) | |
67 "Move the cursor forward by ARG years. | |
68 Movement is backward if ARG is negative." | |
69 (interactive "p") | |
70 (calendar-forward-month (* 12 arg))) | |
71 | |
72 (defun calendar-backward-month (arg) | |
73 "Move the cursor backward by ARG months. | |
74 Movement is forward if ARG is negative." | |
75 (interactive "p") | |
76 (calendar-forward-month (- arg))) | |
77 | |
78 (defun calendar-backward-year (arg) | |
79 "Move the cursor backward ARG years. | |
80 Movement is forward is ARG is negative." | |
81 (interactive "p") | |
82 (calendar-forward-month (* -12 arg))) | |
83 | |
84 (defun scroll-calendar-left (arg) | |
85 "Scroll the displayed calendar left by ARG months. | |
86 If ARG is negative the calendar is scrolled right. Maintains the relative | |
87 position of the cursor with respect to the calendar as well as possible." | |
88 (interactive "p") | |
89 (calendar-cursor-to-nearest-date) | |
90 (let ((old-date (calendar-cursor-to-date)) | |
91 (today (calendar-current-date))) | |
92 (if (/= arg 0) | |
93 (progn | |
94 (increment-calendar-month displayed-month displayed-year arg) | |
95 (generate-calendar-window displayed-month displayed-year) | |
96 (calendar-cursor-to-visible-date | |
97 (cond | |
98 ((calendar-date-is-visible-p old-date) old-date) | |
99 ((calendar-date-is-visible-p today) today) | |
100 (t (list displayed-month 1 displayed-year)))))))) | |
101 | |
102 (defun scroll-calendar-right (arg) | |
103 "Scroll the displayed calendar window right by ARG months. | |
104 If ARG is negative the calendar is scrolled left. Maintains the relative | |
105 position of the cursor with respect to the calendar as well as possible." | |
106 (interactive "p") | |
107 (scroll-calendar-left (- arg))) | |
108 | |
109 (defun scroll-calendar-left-three-months (arg) | |
110 "Scroll the displayed calendar window left by 3*ARG months. | |
111 If ARG is negative the calendar is scrolled right. Maintains the relative | |
112 position of the cursor with respect to the calendar as well as possible." | |
113 (interactive "p") | |
114 (scroll-calendar-left (* 3 arg))) | |
115 | |
116 (defun scroll-calendar-right-three-months (arg) | |
117 "Scroll the displayed calendar window right by 3*ARG months. | |
118 If ARG is negative the calendar is scrolled left. Maintains the relative | |
119 position of the cursor with respect to the calendar as well as possible." | |
120 (interactive "p") | |
121 (scroll-calendar-left (* -3 arg))) | |
122 | |
123 (defun calendar-cursor-to-nearest-date () | |
124 "Move the cursor to the closest date. | |
125 The position of the cursor is unchanged if it is already on a date. | |
126 Returns the list (month day year) giving the cursor position." | |
127 (let ((date (calendar-cursor-to-date)) | |
128 (column (current-column))) | |
129 (if date | |
130 date | |
131 (if (> 3 (count-lines (point-min) (point))) | |
132 (progn | |
133 (goto-line 3) | |
134 (move-to-column column))) | |
135 (if (not (looking-at "[0-9]")) | |
136 (if (and (not (looking-at " *$")) | |
137 (or (< column 25) | |
138 (and (> column 27) | |
139 (< column 50)) | |
140 (and (> column 52) | |
141 (< column 75)))) | |
142 (progn | |
143 (re-search-forward "[0-9]" nil t) | |
144 (backward-char 1)) | |
145 (re-search-backward "[0-9]" nil t))) | |
146 (calendar-cursor-to-date)))) | |
147 | |
148 (defun calendar-forward-day (arg) | |
149 "Move the cursor forward ARG days. | |
150 Moves backward if ARG is negative." | |
151 (interactive "p") | |
152 (if (/= 0 arg) | |
153 (let* | |
154 ((cursor-date (calendar-cursor-to-date)) | |
155 (cursor-date (if cursor-date | |
156 cursor-date | |
157 (if (> arg 0) (setq arg (1- arg))) | |
158 (calendar-cursor-to-nearest-date))) | |
159 (new-cursor-date | |
160 (calendar-gregorian-from-absolute | |
161 (+ (calendar-absolute-from-gregorian cursor-date) arg))) | |
162 (new-display-month (extract-calendar-month new-cursor-date)) | |
163 (new-display-year (extract-calendar-year new-cursor-date))) | |
164 ;; Put the new month on the screen, if needed, and go to the new date. | |
165 (if (not (calendar-date-is-visible-p new-cursor-date)) | |
166 (calendar-other-month new-display-month new-display-year)) | |
167 (calendar-cursor-to-visible-date new-cursor-date)))) | |
168 | |
169 (defun calendar-backward-day (arg) | |
170 "Move the cursor back ARG days. | |
171 Moves forward if ARG is negative." | |
172 (interactive "p") | |
173 (calendar-forward-day (- arg))) | |
174 | |
175 (defun calendar-forward-week (arg) | |
176 "Move the cursor forward ARG weeks. | |
177 Moves backward if ARG is negative." | |
178 (interactive "p") | |
179 (calendar-forward-day (* arg 7))) | |
180 | |
181 (defun calendar-backward-week (arg) | |
182 "Move the cursor back ARG weeks. | |
183 Moves forward if ARG is negative." | |
184 (interactive "p") | |
185 (calendar-forward-day (* arg -7))) | |
186 | |
187 (defun calendar-beginning-of-week (arg) | |
188 "Move the cursor back ARG calendar-week-start-day's." | |
189 (interactive "p") | |
190 (calendar-cursor-to-nearest-date) | |
191 (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) | |
192 (calendar-backward-day | |
193 (if (= day calendar-week-start-day) | |
194 (* 7 arg) | |
195 (+ (mod (- day calendar-week-start-day) 7) | |
196 (* 7 (1- arg))))))) | |
197 | |
198 (defun calendar-end-of-week (arg) | |
199 "Move the cursor forward ARG calendar-week-start-day+6's." | |
200 (interactive "p") | |
201 (calendar-cursor-to-nearest-date) | |
202 (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) | |
203 (calendar-forward-day | |
204 (if (= day (mod (1- calendar-week-start-day) 7)) | |
205 (* 7 arg) | |
206 (+ (- 6 (mod (- day calendar-week-start-day) 7)) | |
207 (* 7 (1- arg))))))) | |
208 | |
209 (defun calendar-beginning-of-month (arg) | |
210 "Move the cursor backward ARG month beginnings." | |
211 (interactive "p") | |
212 (calendar-cursor-to-nearest-date) | |
213 (let* ((date (calendar-cursor-to-date)) | |
214 (month (extract-calendar-month date)) | |
215 (day (extract-calendar-day date)) | |
216 (year (extract-calendar-year date))) | |
217 (if (= day 1) | |
218 (calendar-backward-month arg) | |
219 (calendar-cursor-to-visible-date (list month 1 year)) | |
220 (calendar-backward-month (1- arg))))) | |
221 | |
222 (defun calendar-end-of-month (arg) | |
223 "Move the cursor forward ARG month ends." | |
224 (interactive "p") | |
225 (calendar-cursor-to-nearest-date) | |
226 (let* ((date (calendar-cursor-to-date)) | |
227 (month (extract-calendar-month date)) | |
228 (day (extract-calendar-day date)) | |
229 (year (extract-calendar-year date)) | |
230 (last-day (calendar-last-day-of-month month year))) | |
231 (if (/= day last-day) | |
232 (progn | |
233 (calendar-cursor-to-visible-date (list month last-day year)) | |
234 (setq arg (1- arg)))) | |
235 (increment-calendar-month month year arg) | |
236 (let ((last-day (list | |
237 month | |
238 (calendar-last-day-of-month month year) | |
239 year))) | |
240 (if (not (calendar-date-is-visible-p last-day)) | |
241 (calendar-other-month month year) | |
242 (calendar-cursor-to-visible-date last-day))))) | |
243 | |
244 (defun calendar-beginning-of-year (arg) | |
245 "Move the cursor backward ARG year beginnings." | |
246 (interactive "p") | |
247 (calendar-cursor-to-nearest-date) | |
248 (let* ((date (calendar-cursor-to-date)) | |
249 (month (extract-calendar-month date)) | |
250 (day (extract-calendar-day date)) | |
251 (year (extract-calendar-year date)) | |
252 (jan-first (list 1 1 year))) | |
253 (if (and (= day 1) (= 1 month)) | |
254 (calendar-backward-month (* 12 arg)) | |
255 (if (and (= arg 1) | |
256 (calendar-date-is-visible-p jan-first)) | |
257 (calendar-cursor-to-visible-date jan-first) | |
258 (calendar-other-month 1 (- year (1- arg))))))) | |
259 | |
260 (defun calendar-end-of-year (arg) | |
261 "Move the cursor forward ARG year beginnings." | |
262 (interactive "p") | |
263 (calendar-cursor-to-nearest-date) | |
264 (let* ((date (calendar-cursor-to-date)) | |
265 (month (extract-calendar-month date)) | |
266 (day (extract-calendar-day date)) | |
267 (year (extract-calendar-year date)) | |
268 (dec-31 (list 12 31 year))) | |
269 (if (and (= day 31) (= 12 month)) | |
270 (calendar-forward-month (* 12 arg)) | |
271 (if (and (= arg 1) | |
272 (calendar-date-is-visible-p dec-31)) | |
273 (calendar-cursor-to-visible-date dec-31) | |
274 (calendar-other-month 12 (- year (1- arg))) | |
275 (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))) | |
276 | |
277 (defun calendar-cursor-to-visible-date (date) | |
278 "Move the cursor to DATE that is on the screen." | |
279 (let* ((month (extract-calendar-month date)) | |
280 (day (extract-calendar-day date)) | |
281 (year (extract-calendar-year date)) | |
282 (first-of-month-weekday (calendar-day-of-week (list month 1 year)))) | |
283 (goto-line (+ 3 | |
284 (/ (+ day -1 | |
285 (mod | |
286 (- (calendar-day-of-week (list month 1 year)) | |
287 calendar-week-start-day) | |
288 7)) | |
289 7))) | |
290 (move-to-column (+ 6 | |
291 (* 25 | |
292 (1+ (calendar-interval | |
293 displayed-month displayed-year month year))) | |
294 (* 3 (mod | |
295 (- (calendar-day-of-week date) | |
296 calendar-week-start-day) | |
297 7)))))) | |
298 | |
299 (defun calendar-goto-date (date) | |
300 "Move cursor to DATE." | |
301 (interactive (list (calendar-read-date))) | |
302 (let ((month (extract-calendar-month date)) | |
303 (year (extract-calendar-year date))) | |
304 (if (not (calendar-date-is-visible-p date)) | |
305 (calendar-other-month | |
306 (if (and (= month 1) (= year 1)) | |
307 2 | |
308 month) | |
309 year))) | |
310 (calendar-cursor-to-visible-date date)) | |
311 | |
312 (provide 'cal-move) | |
313 | |
314 ;;; cal-move.el ends here |