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, 2009
   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 &optional event)
 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 EVENT is an event like `last-nonmenu-event'."
 198   (interactive (list (prefix-numeric-value current-prefix-arg)
 199                      last-nonmenu-event))
 200   (calendar-scroll-left (* 3 arg) event))
 201
 202 (define-obsolete-function-alias 'scroll-calendar-left-three-months
 203   'calendar-scroll-left-three-months "23.1")
 204
 205 ;;;###cal-autoload
 206 (defun calendar-scroll-right-three-months (arg &optional event)
 207   "Scroll the displayed calendar window right by 3*ARG months.
 208 If ARG is negative the calendar is scrolled left.  Maintains the relative
 209 position of the cursor with respect to the calendar as well as possible.
 210 EVENT is an event like `last-nonmenu-event'."
 211   (interactive (list (prefix-numeric-value current-prefix-arg)
 212                      last-nonmenu-event))
 213   (calendar-scroll-left (* -3 arg) event))
 214
 215 (define-obsolete-function-alias 'scroll-calendar-right-three-months
 216   'calendar-scroll-right-three-months "23.1")
 217
 218 ;;;###cal-autoload
 219 (defun calendar-forward-day (arg)
 220   "Move the cursor forward ARG days.
 221 Moves backward if ARG is negative."
 222   (interactive "p")
 223   (unless (zerop arg)
 224     (let* ((cursor-date (or (calendar-cursor-to-date)
 225                             (progn
 226                               (if (> arg 0) (setq arg (1- arg)))
 227                               (calendar-cursor-to-nearest-date))))
 228            (new-cursor-date
 229             (calendar-gregorian-from-absolute
 230              (+ (calendar-absolute-from-gregorian cursor-date) arg)))
 231            (new-display-month (calendar-extract-month new-cursor-date))
 232            (new-display-year (calendar-extract-year new-cursor-date)))
 233       ;; Put the new month on the screen, if needed, and go to the new date.
 234       (if (calendar-date-is-visible-p new-cursor-date)
 235           (calendar-cursor-to-visible-date new-cursor-date)
 236         ;; The next line gives smoother scrolling IMO (one month at a
 237         ;; time rather than two).
 238         (calendar-increment-month new-display-month new-display-year
 239                                   (if (< arg 0) 1 -1))
 240         (calendar-other-month new-display-month new-display-year))))
 241   (run-hooks 'calendar-move-hook))
 242
 243 ;;;###cal-autoload
 244 (defun calendar-backward-day (arg)
 245   "Move the cursor back ARG days.
 246 Moves forward if ARG is negative."
 247   (interactive "p")
 248   (calendar-forward-day (- arg)))
 249
 250 ;;;###cal-autoload
 251 (defun calendar-forward-week (arg)
 252   "Move the cursor forward ARG weeks.
 253 Moves backward if ARG is negative."
 254   (interactive "p")
 255   (calendar-forward-day (* arg 7)))
 256
 257 ;;;###cal-autoload
 258 (defun calendar-backward-week (arg)
 259   "Move the cursor back ARG weeks.
 260 Moves forward if ARG is negative."
 261   (interactive "p")
 262   (calendar-forward-day (* arg -7)))
 263
 264 ;;;###cal-autoload
 265 (defun calendar-beginning-of-week (arg)
 266   "Move the cursor back ARG calendar-week-start-day's."
 267   (interactive "p")
 268   (calendar-cursor-to-nearest-date)
 269   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 270     (calendar-backward-day
 271      (if (= day calendar-week-start-day)
 272          (* 7 arg)
 273        (+ (mod (- day calendar-week-start-day) 7)
 274           (* 7 (1- arg)))))))
 275
 276 ;;;###cal-autoload
 277 (defun calendar-end-of-week (arg)
 278   "Move the cursor forward ARG calendar-week-start-day+6's."
 279   (interactive "p")
 280   (calendar-cursor-to-nearest-date)
 281   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 282     (calendar-forward-day
 283      (if (= day (mod (1- calendar-week-start-day) 7))
 284          (* 7 arg)
 285        (+ (- 6 (mod (- day calendar-week-start-day) 7))
 286           (* 7 (1- arg)))))))
 287
 288 ;;;###cal-autoload
 289 (defun calendar-beginning-of-month (arg)
 290   "Move the cursor backward ARG month beginnings."
 291   (interactive "p")
 292   (calendar-cursor-to-nearest-date)
 293   (let* ((date (calendar-cursor-to-date))
 294          (month (calendar-extract-month date))
 295          (day (calendar-extract-day date))
 296          (year (calendar-extract-year date)))
 297     (if (= day 1)
 298         (calendar-backward-month arg)
 299       (calendar-cursor-to-visible-date (list month 1 year))
 300       (calendar-backward-month (1- arg)))))
 301
 302 ;;;###cal-autoload
 303 (defun calendar-end-of-month (arg)
 304   "Move the cursor forward ARG month ends."
 305   (interactive "p")
 306   (calendar-cursor-to-nearest-date)
 307   (let* ((date (calendar-cursor-to-date))
 308          (month (calendar-extract-month date))
 309          (day (calendar-extract-day date))
 310          (year (calendar-extract-year date))
 311          (last-day (calendar-last-day-of-month month year))
 312          (last-day (progn
 313                      (unless (= day last-day)
 314                        (calendar-cursor-to-visible-date
 315                         (list month last-day year))
 316                        (setq arg (1- arg)))
 317                      (calendar-increment-month month year arg)
 318                      (list month
 319                            (calendar-last-day-of-month month year)
 320                            year))))
 321     (if (not (calendar-date-is-visible-p last-day))
 322         (calendar-other-month month year)
 323       (calendar-cursor-to-visible-date last-day)))
 324   (run-hooks 'calendar-move-hook))
 325
 326 ;;;###cal-autoload
 327 (defun calendar-beginning-of-year (arg)
 328   "Move the cursor backward ARG year beginnings."
 329   (interactive "p")
 330   (calendar-cursor-to-nearest-date)
 331   (let* ((date (calendar-cursor-to-date))
 332          (month (calendar-extract-month date))
 333          (day (calendar-extract-day date))
 334          (year (calendar-extract-year date))
 335          (jan-first (list 1 1 year))
 336          (calendar-move-hook nil))
 337     (if (and (= day 1) (= 1 month))
 338         (calendar-backward-month (* 12 arg))
 339       (if (and (= arg 1)
 340                (calendar-date-is-visible-p jan-first))
 341           (calendar-cursor-to-visible-date jan-first)
 342         (calendar-other-month 1 (- year (1- arg)))
 343         (calendar-cursor-to-visible-date (list 1 1 displayed-year)))))
 344   (run-hooks 'calendar-move-hook))
 345
 346 ;;;###cal-autoload
 347 (defun calendar-end-of-year (arg)
 348   "Move the cursor forward ARG year beginnings."
 349   (interactive "p")
 350   (calendar-cursor-to-nearest-date)
 351   (let* ((date (calendar-cursor-to-date))
 352          (month (calendar-extract-month date))
 353          (day (calendar-extract-day date))
 354          (year (calendar-extract-year date))
 355          (dec-31 (list 12 31 year))
 356          (calendar-move-hook nil))
 357     (if (and (= day 31) (= 12 month))
 358         (calendar-forward-month (* 12 arg))
 359       (if (and (= arg 1)
 360                (calendar-date-is-visible-p dec-31))
 361           (calendar-cursor-to-visible-date dec-31)
 362         (calendar-other-month 12 (+ year (1- arg)))
 363         (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))
 364   (run-hooks 'calendar-move-hook))
 365
 366 ;;;###cal-autoload
 367 (defun calendar-goto-date (date)
 368   "Move cursor to DATE."
 369   (interactive (list (calendar-read-date)))
 370   (let ((month (calendar-extract-month date))
 371         (year (calendar-extract-year date)))
 372     (if (not (calendar-date-is-visible-p date))
 373         (calendar-other-month
 374          (if (and (= month 1) (= year 1))
 375              2
 376            month)
 377          year)))
 378   (calendar-cursor-to-visible-date date)
 379   (run-hooks 'calendar-move-hook))
 380
 381 ;;;###cal-autoload
 382 (defun calendar-goto-day-of-year (year day &optional noecho)
 383   "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is non-nil.
 384 Negative DAY counts backward from end of year."
 385   (interactive
 386    (let* ((year (calendar-read
 387                  "Year (>0): "
 388                  (lambda (x) (> x 0))
 389                  (number-to-string (calendar-extract-year
 390                                  (calendar-current-date)))))
 391           (last (if (calendar-leap-year-p year) 366 365))
 392           (day (calendar-read
 393                 (format "Day number (+/- 1-%d): " last)
 394                 (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
 395      (list year day)))
 396   (calendar-goto-date
 397    (calendar-gregorian-from-absolute
 398     (if (< 0 day)
 399         (+ -1 day (calendar-absolute-from-gregorian (list 1 1 year)))
 400       (+ 1 day (calendar-absolute-from-gregorian (list 12 31 year))))))
 401   (or noecho (calendar-print-day-of-year)))
 402
 403 (provide 'cal-move)
 404
 405 ;; arch-tag: d0883c46-7e16-4914-8ff8-8f67e699b781
 406 ;;; cal-move.el ends here