cal-move.el 16.1 KB
Newer Older
Edward M. Reingold's avatar
Edward M. Reingold committed
1 2
;;; cal-move.el --- calendar functions for movement in the calendar

3
;; Copyright (C) 1995, 2001-2011  Free Software Foundation, Inc.
Edward M. Reingold's avatar
Edward M. Reingold committed
4 5

;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
6
;; Maintainer: Glenn Morris <rgm@gnu.org>
Edward M. Reingold's avatar
Edward M. Reingold committed
7 8
;; Keywords: calendar
;; Human-Keywords: calendar
9
;; Package: calendar
Edward M. Reingold's avatar
Edward M. Reingold committed
10 11 12

;; This file is part of GNU Emacs.

13
;; GNU Emacs is free software: you can redistribute it and/or modify
Edward M. Reingold's avatar
Edward M. Reingold committed
14
;; it under the terms of the GNU General Public License as published by
15 16
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Edward M. Reingold's avatar
Edward M. Reingold committed
17 18 19 20 21 22 23

;; 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
24
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Edward M. Reingold's avatar
Edward M. Reingold committed
25 26 27

;;; Commentary:

28
;; See calendar.el.
Edward M. Reingold's avatar
Edward M. Reingold committed
29 30 31

;;; Code:

32
;; FIXME should calendar just require this?
33 34
(require 'calendar)

35 36 37

;; Note that this is not really the "closest" date.
;; In most cases, it just searches forwards for the next day.
38 39 40 41 42
;;;###cal-autoload
(defun calendar-cursor-to-nearest-date ()
  "Move the cursor to the closest date.
The position of the cursor is unchanged if it is already on a date.
Returns the list (month day year) giving the cursor position."
43
  (or (calendar-cursor-to-date)
44 45 46 47 48 49
      (let* ((col (current-column))
             (edges (cdr (assoc (calendar-column-to-segment)
                                calendar-month-edges)))
             (last (nth 2 edges))
             (right (nth 3 edges)))
        (when (< (count-lines (point-min) (point)) calendar-first-date-row)
50 51
          (goto-char (point-min))
          (forward-line (1- calendar-first-date-row))
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
          (move-to-column col))
        ;; The date positions are fixed and computable, but searching
        ;; is probably more flexible.  Need to consider blank days at
        ;; start and end of month if computing positions.
        ;; 'date text-property is used to exclude intermonth text.
        (unless (and (looking-at "[0-9]")
                     (get-text-property (point) 'date))
          ;; We search forwards for a number, except close to the RH
          ;; margin of a month, where we search backwards.
          ;; Note that the searches can go to other lines.
          (if (or (looking-at " *$")
                  (and (> col last) (< col right)))
              (while (and (re-search-backward "[0-9]" nil t)
                          (not (get-text-property (point) 'date))))
            (while (and (re-search-forward "[0-9]" nil t)
                        (not (get-text-property (1- (point)) 'date))))
            (backward-char 1)))
69 70
        (calendar-cursor-to-date))))

71
(defvar displayed-month)                ; from calendar-generate
72 73
(defvar displayed-year)

74 75 76
;;;###cal-autoload
(defun calendar-cursor-to-visible-date (date)
  "Move the cursor to DATE that is on the screen."
77 78 79
  (let ((month (calendar-extract-month date))
        (day (calendar-extract-day date))
        (year (calendar-extract-year date)))
80 81 82 83 84 85 86 87
    (goto-char (point-min))
    (forward-line (+ calendar-first-date-row -1
                     (/ (+ day -1
                           (mod
                            (- (calendar-day-of-week (list month 1 year))
                               calendar-week-start-day)
                            7))
                        7)))
88 89
    (move-to-column (+ calendar-left-margin (1- calendar-day-digit-width)
                       (* calendar-month-width
90 91
                          (1+ (calendar-interval
                               displayed-month displayed-year month year)))
92 93 94 95 96
                       (* calendar-column-width
                          (mod
                           (- (calendar-day-of-week date)
                              calendar-week-start-day)
                           7))))))
Richard M. Stallman's avatar
Richard M. Stallman committed
97

98
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
99 100 101
(defun calendar-goto-today ()
  "Reposition the calendar window so the current date is visible."
  (interactive)
102
  (let ((today (calendar-current-date))) ; the date might have changed
Edward M. Reingold's avatar
Edward M. Reingold committed
103
    (if (not (calendar-date-is-visible-p today))
104 105
        (calendar-generate-window)
      (calendar-update-mode-line)
106 107
      (calendar-cursor-to-visible-date today)))
  (run-hooks 'calendar-move-hook))
Edward M. Reingold's avatar
Edward M. Reingold committed
108

109
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
110 111 112 113 114 115
(defun calendar-forward-month (arg)
  "Move the cursor forward ARG months.
Movement is backward if ARG is negative."
  (interactive "p")
  (calendar-cursor-to-nearest-date)
  (let* ((cursor-date (calendar-cursor-to-date t))
116 117 118
         (month (calendar-extract-month cursor-date))
         (day (calendar-extract-day cursor-date))
         (year (calendar-extract-year cursor-date))
119
         (last (progn
120
                 (calendar-increment-month month year arg)
121 122 123 124 125 126 127
                 (calendar-last-day-of-month month year)))
         (day (min last day))
         ;; Put the new month on the screen, if needed, and go to the new date.
         (new-cursor-date (list month day year)))
    (if (not (calendar-date-is-visible-p new-cursor-date))
        (calendar-other-month month year))
    (calendar-cursor-to-visible-date new-cursor-date))
128
  (run-hooks 'calendar-move-hook))
Edward M. Reingold's avatar
Edward M. Reingold committed
129

130
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
131 132 133 134 135 136
(defun calendar-forward-year (arg)
  "Move the cursor forward by ARG years.
Movement is backward if ARG is negative."
  (interactive "p")
  (calendar-forward-month (* 12 arg)))

137
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
138 139 140 141 142 143
(defun calendar-backward-month (arg)
  "Move the cursor backward by ARG months.
Movement is forward if ARG is negative."
  (interactive "p")
  (calendar-forward-month (- arg)))

144
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
145 146 147 148 149 150
(defun calendar-backward-year (arg)
  "Move the cursor backward ARG years.
Movement is forward is ARG is negative."
  (interactive "p")
  (calendar-forward-month (* -12 arg)))

151
;;;###cal-autoload
152
(defun calendar-scroll-left (&optional arg event)
Edward M. Reingold's avatar
Edward M. Reingold committed
153 154
  "Scroll the displayed calendar left by ARG months.
If ARG is negative the calendar is scrolled right.  Maintains the relative
155 156
position of the cursor with respect to the calendar as well as possible.
EVENT is an event like `last-nonmenu-event'."
157 158
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
Dave Love's avatar
Dave Love committed
159
  (unless arg (setq arg 1))
160
  (save-selected-window
161 162
    ;; Nil if called from menu-bar.
    (if (setq event (event-start event)) (select-window (posn-window event)))
163
    (calendar-cursor-to-nearest-date)
164 165 166 167 168
    (unless (zerop arg)
      (let ((old-date (calendar-cursor-to-date))
            (today (calendar-current-date))
            (month displayed-month)
            (year displayed-year))
169 170
        (calendar-increment-month month year arg)
        (calendar-generate-window month year)
171 172 173 174 175
        (calendar-cursor-to-visible-date
         (cond
          ((calendar-date-is-visible-p old-date) old-date)
          ((calendar-date-is-visible-p today) today)
          (t (list month 1 year))))))
176 177
    (run-hooks 'calendar-move-hook)))

178 179 180
(define-obsolete-function-alias
  'scroll-calendar-left 'calendar-scroll-left "23.1")

181
;;;###cal-autoload
182
(defun calendar-scroll-right (&optional arg event)
Edward M. Reingold's avatar
Edward M. Reingold committed
183 184
  "Scroll the displayed calendar window right by ARG months.
If ARG is negative the calendar is scrolled left.  Maintains the relative
185 186
position of the cursor with respect to the calendar as well as possible.
EVENT is an event like `last-nonmenu-event'."
187 188 189
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
  (calendar-scroll-left (- (or arg 1)) event))
Edward M. Reingold's avatar
Edward M. Reingold committed
190

191 192 193
(define-obsolete-function-alias
  'scroll-calendar-right 'calendar-scroll-right "23.1")

194
;;;###cal-autoload
195
(defun calendar-scroll-left-three-months (arg &optional event)
Edward M. Reingold's avatar
Edward M. Reingold committed
196 197
  "Scroll the displayed calendar window left by 3*ARG months.
If ARG is negative the calendar is scrolled right.  Maintains the relative
198 199 200 201 202
position of the cursor with respect to the calendar as well as possible.
EVENT is an event like `last-nonmenu-event'."
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
  (calendar-scroll-left (* 3 arg) event))
Edward M. Reingold's avatar
Edward M. Reingold committed
203

204 205 206
(define-obsolete-function-alias 'scroll-calendar-left-three-months
  'calendar-scroll-left-three-months "23.1")

207 208 209 210 211 212 213 214 215 216 217 218
;; cf scroll-bar-toolkit-scroll
;;;###cal-autoload
(defun calendar-scroll-toolkit-scroll (event)
  "Function to scroll the calendar after a toolkit scroll-bar click."
  (interactive "e")
  (let ((part (nth 4 (event-end event))))
    ;; Not bothering with drag events (handle, end-scroll).
    (cond ((memq part '(above-handle up top))
           (calendar-scroll-right nil event))
          ((memq part '(below-handle down bottom))
           (calendar-scroll-left nil event)))))

219
;;;###cal-autoload
220
(defun calendar-scroll-right-three-months (arg &optional event)
Edward M. Reingold's avatar
Edward M. Reingold committed
221 222
  "Scroll the displayed calendar window right by 3*ARG months.
If ARG is negative the calendar is scrolled left.  Maintains the relative
223 224 225 226 227
position of the cursor with respect to the calendar as well as possible.
EVENT is an event like `last-nonmenu-event'."
  (interactive (list (prefix-numeric-value current-prefix-arg)
                     last-nonmenu-event))
  (calendar-scroll-left (* -3 arg) event))
Edward M. Reingold's avatar
Edward M. Reingold committed
228

229 230
(define-obsolete-function-alias 'scroll-calendar-right-three-months
  'calendar-scroll-right-three-months "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
231

232
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
233 234 235 236
(defun calendar-forward-day (arg)
  "Move the cursor forward ARG days.
Moves backward if ARG is negative."
  (interactive "p")
237 238 239 240 241
  (unless (zerop arg)
    (let* ((cursor-date (or (calendar-cursor-to-date)
                            (progn
                              (if (> arg 0) (setq arg (1- arg)))
                              (calendar-cursor-to-nearest-date))))
Edward M. Reingold's avatar
Edward M. Reingold committed
242 243 244
           (new-cursor-date
            (calendar-gregorian-from-absolute
             (+ (calendar-absolute-from-gregorian cursor-date) arg)))
245 246
           (new-display-month (calendar-extract-month new-cursor-date))
           (new-display-year (calendar-extract-year new-cursor-date)))
247 248
      ;; Put the new month on the screen, if needed.
      (unless (calendar-date-is-visible-p new-cursor-date)
249 250 251 252
        ;; The next line gives smoother scrolling IMO (one month at a
        ;; time rather than two).
        (calendar-increment-month new-display-month new-display-year
                                  (if (< arg 0) 1 -1))
253 254 255
        (calendar-other-month new-display-month new-display-year))
      ;; Go to the new date.
      (calendar-cursor-to-visible-date new-cursor-date)))
256
  (run-hooks 'calendar-move-hook))
Edward M. Reingold's avatar
Edward M. Reingold committed
257

258
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
259 260 261 262 263 264
(defun calendar-backward-day (arg)
  "Move the cursor back ARG days.
Moves forward if ARG is negative."
  (interactive "p")
  (calendar-forward-day (- arg)))

265
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
266 267 268 269 270 271
(defun calendar-forward-week (arg)
  "Move the cursor forward ARG weeks.
Moves backward if ARG is negative."
  (interactive "p")
  (calendar-forward-day (* arg 7)))

272
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
273 274 275 276 277 278
(defun calendar-backward-week (arg)
  "Move the cursor back ARG weeks.
Moves forward if ARG is negative."
  (interactive "p")
  (calendar-forward-day (* arg -7)))

279
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
280 281 282 283 284 285 286 287 288 289 290
(defun calendar-beginning-of-week (arg)
  "Move the cursor back ARG calendar-week-start-day's."
  (interactive "p")
  (calendar-cursor-to-nearest-date)
  (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
    (calendar-backward-day
     (if (= day calendar-week-start-day)
         (* 7 arg)
       (+ (mod (- day calendar-week-start-day) 7)
          (* 7 (1- arg)))))))

291
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
292 293 294 295 296 297 298 299 300 301 302
(defun calendar-end-of-week (arg)
  "Move the cursor forward ARG calendar-week-start-day+6's."
  (interactive "p")
  (calendar-cursor-to-nearest-date)
  (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
    (calendar-forward-day
     (if (= day (mod (1- calendar-week-start-day) 7))
         (* 7 arg)
       (+ (- 6 (mod (- day calendar-week-start-day) 7))
          (* 7 (1- arg)))))))

303
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
304 305 306 307 308
(defun calendar-beginning-of-month (arg)
  "Move the cursor backward ARG month beginnings."
  (interactive "p")
  (calendar-cursor-to-nearest-date)
  (let* ((date (calendar-cursor-to-date))
309 310 311
         (month (calendar-extract-month date))
         (day (calendar-extract-day date))
         (year (calendar-extract-year date)))
Edward M. Reingold's avatar
Edward M. Reingold committed
312 313 314 315 316
    (if (= day 1)
        (calendar-backward-month arg)
      (calendar-cursor-to-visible-date (list month 1 year))
      (calendar-backward-month (1- arg)))))

317
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
318 319 320 321 322
(defun calendar-end-of-month (arg)
  "Move the cursor forward ARG month ends."
  (interactive "p")
  (calendar-cursor-to-nearest-date)
  (let* ((date (calendar-cursor-to-date))
323 324 325
         (month (calendar-extract-month date))
         (day (calendar-extract-day date))
         (year (calendar-extract-year date))
326 327 328 329 330 331
         (last-day (calendar-last-day-of-month month year))
         (last-day (progn
                     (unless (= day last-day)
                       (calendar-cursor-to-visible-date
                        (list month last-day year))
                       (setq arg (1- arg)))
332
                     (calendar-increment-month month year arg)
333 334 335 336 337 338
                     (list month
                           (calendar-last-day-of-month month year)
                           year))))
    (if (not (calendar-date-is-visible-p last-day))
        (calendar-other-month month year)
      (calendar-cursor-to-visible-date last-day)))
339
  (run-hooks 'calendar-move-hook))
Edward M. Reingold's avatar
Edward M. Reingold committed
340

341
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
342 343 344 345 346
(defun calendar-beginning-of-year (arg)
  "Move the cursor backward ARG year beginnings."
  (interactive "p")
  (calendar-cursor-to-nearest-date)
  (let* ((date (calendar-cursor-to-date))
347 348 349
         (month (calendar-extract-month date))
         (day (calendar-extract-day date))
         (year (calendar-extract-year date))
350 351
         (jan-first (list 1 1 year))
         (calendar-move-hook nil))
Edward M. Reingold's avatar
Edward M. Reingold committed
352 353 354 355 356
    (if (and (= day 1) (= 1 month))
        (calendar-backward-month (* 12 arg))
      (if (and (= arg 1)
               (calendar-date-is-visible-p jan-first))
          (calendar-cursor-to-visible-date jan-first)
357 358
        (calendar-other-month 1 (- year (1- arg)))
        (calendar-cursor-to-visible-date (list 1 1 displayed-year)))))
359
  (run-hooks 'calendar-move-hook))
Edward M. Reingold's avatar
Edward M. Reingold committed
360

361
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
362 363 364 365 366
(defun calendar-end-of-year (arg)
  "Move the cursor forward ARG year beginnings."
  (interactive "p")
  (calendar-cursor-to-nearest-date)
  (let* ((date (calendar-cursor-to-date))
367 368 369
         (month (calendar-extract-month date))
         (day (calendar-extract-day date))
         (year (calendar-extract-year date))
370 371
         (dec-31 (list 12 31 year))
         (calendar-move-hook nil))
Edward M. Reingold's avatar
Edward M. Reingold committed
372 373 374 375 376
    (if (and (= day 31) (= 12 month))
        (calendar-forward-month (* 12 arg))
      (if (and (= arg 1)
               (calendar-date-is-visible-p dec-31))
          (calendar-cursor-to-visible-date dec-31)
377
        (calendar-other-month 12 (+ year (1- arg)))
378 379
        (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))
  (run-hooks 'calendar-move-hook))
Edward M. Reingold's avatar
Edward M. Reingold committed
380

381
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
382 383 384
(defun calendar-goto-date (date)
  "Move cursor to DATE."
  (interactive (list (calendar-read-date)))
385 386
  (let ((month (calendar-extract-month date))
        (year (calendar-extract-year date)))
Edward M. Reingold's avatar
Edward M. Reingold committed
387 388 389 390 391 392
    (if (not (calendar-date-is-visible-p date))
        (calendar-other-month
         (if (and (= month 1) (= year 1))
             2
           month)
         year)))
393 394
  (calendar-cursor-to-visible-date date)
  (run-hooks 'calendar-move-hook))
Edward M. Reingold's avatar
Edward M. Reingold committed
395

396
;;;###cal-autoload
397
(defun calendar-goto-day-of-year (year day &optional noecho)
398
  "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil.
399 400 401 402 403
Negative DAY counts backward from end of year."
  (interactive
   (let* ((year (calendar-read
                 "Year (>0): "
                 (lambda (x) (> x 0))
404
                 (number-to-string (calendar-extract-year
405 406 407 408
                                 (calendar-current-date)))))
          (last (if (calendar-leap-year-p year) 366 365))
          (day (calendar-read
                (format "Day number (+/- 1-%d): " last)
409
                (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
410 411 412 413 414 415 416 417
     (list year day)))
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (if (< 0 day)
        (+ -1 day (calendar-absolute-from-gregorian (list 1 1 year)))
      (+ 1 day (calendar-absolute-from-gregorian (list 12 31 year))))))
  (or noecho (calendar-print-day-of-year)))

Edward M. Reingold's avatar
Edward M. Reingold committed
418 419 420
(provide 'cal-move)

;;; cal-move.el ends here