code.delx.au - gnu-emacs/blob - lisp/calendar/cal-move.el

   1 ;;; cal-move.el --- calendar functions for movement in the calendar
   2
   3 ;; Copyright (C) 1995, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   8 ;; Keywords: calendar
   9 ;; Human-Keywords: calendar
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; 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/>.
  25
  26 ;;; Commentary:
  27
  28 ;; See calendar.el.
  29
  30 ;;; Code:
  31
  32 ;; FIXME should calendar just require this?
  33 (require 'calendar)
  34
  35
  36 ;; Note that this is not really the "closest" date.
  37 ;; In most cases, it just searches forwards for the next day.
  38 ;;;###cal-autoload
  39 (defun calendar-cursor-to-nearest-date ()
  40   "Move the cursor to the closest date.
  41 The position of the cursor is unchanged if it is already on a date.
  42 Returns the list (month day year) giving the cursor position."
  43   (or (calendar-cursor-to-date)
  44       (let* ((col (current-column))
  45              (edges (cdr (assoc (calendar-column-to-segment)
  46                                 calendar-month-edges)))
  47              (last (nth 2 edges))
  48              (right (nth 3 edges)))
  49         (when (< (count-lines (point-min) (point)) calendar-first-date-row)
  50           (goto-line calendar-first-date-row)
  51           (move-to-column col))
  52         ;; The date positions are fixed and computable, but searching
  53         ;; is probably more flexible.  Need to consider blank days at
  54         ;; start and end of month if computing positions.
  55         ;; 'date text-property is used to exclude intermonth text.
  56         (unless (and (looking-at "[0-9]")
  57                      (get-text-property (point) 'date))
  58           ;; We search forwards for a number, except close to the RH
  59           ;; margin of a month, where we search backwards.
  60           ;; Note that the searches can go to other lines.
  61           (if (or (looking-at " *$")
  62                   (and (> col last) (< col right)))
  63               (while (and (re-search-backward "[0-9]" nil t)
  64                           (not (get-text-property (point) 'date))))
  65             (while (and (re-search-forward "[0-9]" nil t)
  66                         (not (get-text-property (1- (point)) 'date))))
  67             (backward-char 1)))
  68         (calendar-cursor-to-date))))
  69
  70 (defvar displayed-month)                ; from calendar-generate
  71 (defvar displayed-year)
  72
  73 ;;;###cal-autoload
  74 (defun calendar-cursor-to-visible-date (date)
  75   "Move the cursor to DATE that is on the screen."
  76   (let ((month (calendar-extract-month date))
  77         (day (calendar-extract-day date))
  78         (year (calendar-extract-year date)))
  79     (goto-line (+ calendar-first-date-row
  80                   (/ (+ day  -1
  81                         (mod
  82                          (- (calendar-day-of-week (list month 1 year))
  83                             calendar-week-start-day)
  84                          7))
  85                      7)))
  86     (move-to-column (+ calendar-left-margin (1- calendar-day-digit-width)
  87                        (* calendar-month-width
  88                           (1+ (calendar-interval
  89                                displayed-month displayed-year month year)))
  90                        (* calendar-column-width
  91                           (mod
  92                            (- (calendar-day-of-week date)
  93                               calendar-week-start-day)
  94                            7))))))
  95
  96 ;;;###cal-autoload
  97 (defun calendar-goto-today ()
  98   "Reposition the calendar window so the current date is visible."
  99   (interactive)
 100   (let ((today (calendar-current-date))) ; the date might have changed
 101     (if (not (calendar-date-is-visible-p today))
 102         (calendar-generate-window)
 103       (calendar-update-mode-line)
 104       (calendar-cursor-to-visible-date today)))
 105   (run-hooks 'calendar-move-hook))
 106
 107 ;;;###cal-autoload
 108 (defun calendar-forward-month (arg)
 109   "Move the cursor forward ARG months.
 110 Movement is backward if ARG is negative."
 111   (interactive "p")
 112   (calendar-cursor-to-nearest-date)
 113   (let* ((cursor-date (calendar-cursor-to-date t))
 114          (month (calendar-extract-month cursor-date))
 115          (day (calendar-extract-day cursor-date))
 116          (year (calendar-extract-year cursor-date))
 117          (last (progn
 118                  (calendar-increment-month month year arg)
 119                  (calendar-last-day-of-month month year)))
 120          (day (min last day))
 121          ;; Put the new month on the screen, if needed, and go to the new date.
 122          (new-cursor-date (list month day year)))
 123     (if (not (calendar-date-is-visible-p new-cursor-date))
 124         (calendar-other-month month year))
 125     (calendar-cursor-to-visible-date new-cursor-date))
 126   (run-hooks 'calendar-move-hook))
 127
 128 ;;;###cal-autoload
 129 (defun calendar-forward-year (arg)
 130   "Move the cursor forward by ARG years.
 131 Movement is backward if ARG is negative."
 132   (interactive "p")
 133   (calendar-forward-month (* 12 arg)))
 134
 135 ;;;###cal-autoload
 136 (defun calendar-backward-month (arg)
 137   "Move the cursor backward by ARG months.
 138 Movement is forward if ARG is negative."
 139   (interactive "p")
 140   (calendar-forward-month (- arg)))
 141
 142 ;;;###cal-autoload
 143 (defun calendar-backward-year (arg)
 144   "Move the cursor backward ARG years.
 145 Movement is forward is ARG is negative."
 146   (interactive "p")
 147   (calendar-forward-month (* -12 arg)))
 148
 149 ;;;###cal-autoload
 150 (defun calendar-scroll-left (&optional arg event)
 151   "Scroll the displayed calendar left by ARG months.
 152 If ARG is negative the calendar is scrolled right.  Maintains the relative
 153 position of the cursor with respect to the calendar as well as possible.
 154 EVENT is an event like `last-nonmenu-event'."
 155   (interactive (list (prefix-numeric-value current-prefix-arg)
 156                      last-nonmenu-event))
 157   (unless arg (setq arg 1))
 158   (save-selected-window
 159     ;; Nil if called from menu-bar.
 160     (if (setq event (event-start event)) (select-window (posn-window event)))
 161     (calendar-cursor-to-nearest-date)
 162     (unless (zerop arg)
 163       (let ((old-date (calendar-cursor-to-date))
 164             (today (calendar-current-date))
 165             (month displayed-month)
 166             (year displayed-year))
 167         (calendar-increment-month month year arg)
 168         (calendar-generate-window month year)
 169         (calendar-cursor-to-visible-date
 170          (cond
 171           ((calendar-date-is-visible-p old-date) old-date)
 172           ((calendar-date-is-visible-p today) today)
 173           (t (list month 1 year))))))
 174     (run-hooks 'calendar-move-hook)))
 175
 176 (define-obsolete-function-alias
 177   'scroll-calendar-left 'calendar-scroll-left "23.1")
 178
 179 ;;;###cal-autoload
 180 (defun calendar-scroll-right (&optional arg event)
 181   "Scroll the displayed calendar window right by ARG months.
 182 If ARG is negative the calendar is scrolled left.  Maintains the relative
 183 position of the cursor with respect to the calendar as well as possible.
 184 EVENT is an event like `last-nonmenu-event'."
 185   (interactive (list (prefix-numeric-value current-prefix-arg)
 186                      last-nonmenu-event))
 187   (calendar-scroll-left (- (or arg 1)) event))
 188
 189 (define-obsolete-function-alias
 190   'scroll-calendar-right 'calendar-scroll-right "23.1")
 191
 192 ;;;###cal-autoload
 193 (defun calendar-scroll-left-three-months (arg)
 194   "Scroll the displayed calendar window left by 3*ARG months.
 195 If ARG is negative the calendar is scrolled right.  Maintains the relative
 196 position of the cursor with respect to the calendar as well as possible."
 197   (interactive "p")
 198   (calendar-scroll-left (* 3 arg)))
 199
 200 (define-obsolete-function-alias 'scroll-calendar-left-three-months
 201   'calendar-scroll-left-three-months "23.1")
 202
 203 ;;;###cal-autoload
 204 (defun calendar-scroll-right-three-months (arg)
 205   "Scroll the displayed calendar window right by 3*ARG months.
 206 If ARG is negative the calendar is scrolled left.  Maintains the relative
 207 position of the cursor with respect to the calendar as well as possible."
 208   (interactive "p")
 209   (calendar-scroll-left (* -3 arg)))
 210
 211 (define-obsolete-function-alias 'scroll-calendar-right-three-months
 212   'calendar-scroll-right-three-months "23.1")
 213
 214 ;;;###cal-autoload
 215 (defun calendar-forward-day (arg)
 216   "Move the cursor forward ARG days.
 217 Moves backward if ARG is negative."
 218   (interactive "p")
 219   (unless (zerop arg)
 220     (let* ((cursor-date (or (calendar-cursor-to-date)
 221                             (progn
 222                               (if (> arg 0) (setq arg (1- arg)))
 223                               (calendar-cursor-to-nearest-date))))
 224            (new-cursor-date
 225             (calendar-gregorian-from-absolute
 226              (+ (calendar-absolute-from-gregorian cursor-date) arg)))
 227            (new-display-month (calendar-extract-month new-cursor-date))
 228            (new-display-year (calendar-extract-year new-cursor-date)))
 229       ;; Put the new month on the screen, if needed, and go to the new date.
 230       (if (calendar-date-is-visible-p new-cursor-date)
 231           (calendar-cursor-to-visible-date new-cursor-date)
 232         ;; The next line gives smoother scrolling IMO (one month at a
 233         ;; time rather than two).
 234         (calendar-increment-month new-display-month new-display-year
 235                                   (if (< arg 0) 1 -1))
 236         (calendar-other-month new-display-month new-display-year))))
 237   (run-hooks 'calendar-move-hook))
 238
 239 ;;;###cal-autoload
 240 (defun calendar-backward-day (arg)
 241   "Move the cursor back ARG days.
 242 Moves forward if ARG is negative."
 243   (interactive "p")
 244   (calendar-forward-day (- arg)))
 245
 246 ;;;###cal-autoload
 247 (defun calendar-forward-week (arg)
 248   "Move the cursor forward ARG weeks.
 249 Moves backward if ARG is negative."
 250   (interactive "p")
 251   (calendar-forward-day (* arg 7)))
 252
 253 ;;;###cal-autoload
 254 (defun calendar-backward-week (arg)
 255   "Move the cursor back ARG weeks.
 256 Moves forward if ARG is negative."
 257   (interactive "p")
 258   (calendar-forward-day (* arg -7)))
 259
 260 ;;;###cal-autoload
 261 (defun calendar-beginning-of-week (arg)
 262   "Move the cursor back ARG calendar-week-start-day's."
 263   (interactive "p")
 264   (calendar-cursor-to-nearest-date)
 265   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 266     (calendar-backward-day
 267      (if (= day calendar-week-start-day)
 268          (* 7 arg)
 269        (+ (mod (- day calendar-week-start-day) 7)
 270           (* 7 (1- arg)))))))
 271
 272 ;;;###cal-autoload
 273 (defun calendar-end-of-week (arg)
 274   "Move the cursor forward ARG calendar-week-start-day+6's."
 275   (interactive "p")
 276   (calendar-cursor-to-nearest-date)
 277   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 278     (calendar-forward-day
 279      (if (= day (mod (1- calendar-week-start-day) 7))
 280          (* 7 arg)
 281        (+ (- 6 (mod (- day calendar-week-start-day) 7))
 282           (* 7 (1- arg)))))))
 283
 284 ;;;###cal-autoload
 285 (defun calendar-beginning-of-month (arg)
 286   "Move the cursor backward ARG month beginnings."
 287   (interactive "p")
 288   (calendar-cursor-to-nearest-date)
 289   (let* ((date (calendar-cursor-to-date))
 290          (month (calendar-extract-month date))
 291          (day (calendar-extract-day date))
 292          (year (calendar-extract-year date)))
 293     (if (= day 1)
 294         (calendar-backward-month arg)
 295       (calendar-cursor-to-visible-date (list month 1 year))
 296       (calendar-backward-month (1- arg)))))
 297
 298 ;;;###cal-autoload
 299 (defun calendar-end-of-month (arg)
 300   "Move the cursor forward ARG month ends."
 301   (interactive "p")
 302   (calendar-cursor-to-nearest-date)
 303   (let* ((date (calendar-cursor-to-date))
 304          (month (calendar-extract-month date))
 305          (day (calendar-extract-day date))
 306          (year (calendar-extract-year date))
 307          (last-day (calendar-last-day-of-month month year))
 308          (last-day (progn
 309                      (unless (= day last-day)
 310                        (calendar-cursor-to-visible-date
 311                         (list month last-day year))
 312                        (setq arg (1- arg)))
 313                      (calendar-increment-month month year arg)
 314                      (list month
 315                            (calendar-last-day-of-month month year)
 316                            year))))
 317     (if (not (calendar-date-is-visible-p last-day))
 318         (calendar-other-month month year)
 319       (calendar-cursor-to-visible-date last-day)))
 320   (run-hooks 'calendar-move-hook))
 321
 322 ;;;###cal-autoload
 323 (defun calendar-beginning-of-year (arg)
 324   "Move the cursor backward ARG year beginnings."
 325   (interactive "p")
 326   (calendar-cursor-to-nearest-date)
 327   (let* ((date (calendar-cursor-to-date))
 328          (month (calendar-extract-month date))
 329          (day (calendar-extract-day date))
 330          (year (calendar-extract-year date))
 331          (jan-first (list 1 1 year))
 332          (calendar-move-hook nil))
 333     (if (and (= day 1) (= 1 month))
 334         (calendar-backward-month (* 12 arg))
 335       (if (and (= arg 1)
 336                (calendar-date-is-visible-p jan-first))
 337           (calendar-cursor-to-visible-date jan-first)
 338         (calendar-other-month 1 (- year (1- arg)))
 339         (calendar-cursor-to-visible-date (list 1 1 displayed-year)))))
 340   (run-hooks 'calendar-move-hook))
 341
 342 ;;;###cal-autoload
 343 (defun calendar-end-of-year (arg)
 344   "Move the cursor forward ARG year beginnings."
 345   (interactive "p")
 346   (calendar-cursor-to-nearest-date)
 347   (let* ((date (calendar-cursor-to-date))
 348          (month (calendar-extract-month date))
 349          (day (calendar-extract-day date))
 350          (year (calendar-extract-year date))
 351          (dec-31 (list 12 31 year))
 352          (calendar-move-hook nil))
 353     (if (and (= day 31) (= 12 month))
 354         (calendar-forward-month (* 12 arg))
 355       (if (and (= arg 1)
 356                (calendar-date-is-visible-p dec-31))
 357           (calendar-cursor-to-visible-date dec-31)
 358         (calendar-other-month 12 (+ year (1- arg)))
 359         (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))
 360   (run-hooks 'calendar-move-hook))
 361
 362 ;;;###cal-autoload
 363 (defun calendar-goto-date (date)
 364   "Move cursor to DATE."
 365   (interactive (list (calendar-read-date)))
 366   (let ((month (calendar-extract-month date))
 367         (year (calendar-extract-year date)))
 368     (if (not (calendar-date-is-visible-p date))
 369         (calendar-other-month
 370          (if (and (= month 1) (= year 1))
 371              2
 372            month)
 373          year)))
 374   (calendar-cursor-to-visible-date date)
 375   (run-hooks 'calendar-move-hook))
 376
 377 ;;;###cal-autoload
 378 (defun calendar-goto-day-of-year (year day &optional noecho)
 379   "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil.
 380 Negative DAY counts backward from end of year."
 381   (interactive
 382    (let* ((year (calendar-read
 383                  "Year (>0): "
 384                  (lambda (x) (> x 0))
 385                  (number-to-string (calendar-extract-year
 386                                  (calendar-current-date)))))
 387           (last (if (calendar-leap-year-p year) 366 365))
 388           (day (calendar-read
 389                 (format "Day number (+/- 1-%d): " last)
 390                 (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
 391      (list year day)))
 392   (calendar-goto-date
 393    (calendar-gregorian-from-absolute
 394     (if (< 0 day)
 395         (+ -1 day (calendar-absolute-from-gregorian (list 1 1 year)))
 396       (+ 1 day (calendar-absolute-from-gregorian (list 12 31 year))))))
 397   (or noecho (calendar-print-day-of-year)))
 398
 399 (provide 'cal-move)
 400
 401 ;; arch-tag: d0883c46-7e16-4914-8ff8-8f67e699b781
 402 ;;; cal-move.el ends here