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, or (at your option)
  16 ;; 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; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This collection of functions implements movement in the calendar for
  31 ;; calendar.el.
  32
  33 ;;; Code:
  34
  35 (defvar displayed-month)
  36 (defvar displayed-year)
  37
  38 (require 'calendar)
  39
  40 ;;;###autoload
  41 (defun calendar-goto-today ()
  42   "Reposition the calendar window so the current date is visible."
  43   (interactive)
  44   (let ((today (calendar-current-date)));; The date might have changed.
  45     (if (not (calendar-date-is-visible-p today))
  46         (generate-calendar-window)
  47       (update-calendar-mode-line)
  48       (calendar-cursor-to-visible-date today)))
  49   (run-hooks 'calendar-move-hook))
  50
  51 ;;;###autoload
  52 (defun calendar-forward-month (arg)
  53   "Move the cursor forward ARG months.
  54 Movement is backward if ARG is negative."
  55   (interactive "p")
  56   (calendar-cursor-to-nearest-date)
  57   (let* ((cursor-date (calendar-cursor-to-date t))
  58          (month (extract-calendar-month cursor-date))
  59          (day (extract-calendar-day cursor-date))
  60          (year (extract-calendar-year cursor-date)))
  61     (increment-calendar-month month year arg)
  62     (let ((last (calendar-last-day-of-month month year)))
  63       (if (< last day)
  64         (setq day last)))
  65     ;; Put the new month on the screen, if needed, and go to the new date.
  66     (let ((new-cursor-date (list month day year)))
  67       (if (not (calendar-date-is-visible-p new-cursor-date))
  68           (calendar-other-month month year))
  69       (calendar-cursor-to-visible-date new-cursor-date)))
  70   (run-hooks 'calendar-move-hook))
  71
  72 ;;;###autoload
  73 (defun calendar-forward-year (arg)
  74   "Move the cursor forward by ARG years.
  75 Movement is backward if ARG is negative."
  76   (interactive "p")
  77   (calendar-forward-month (* 12 arg)))
  78
  79 ;;;###autoload
  80 (defun calendar-backward-month (arg)
  81   "Move the cursor backward by ARG months.
  82 Movement is forward if ARG is negative."
  83   (interactive "p")
  84   (calendar-forward-month (- arg)))
  85
  86 ;;;###autoload
  87 (defun calendar-backward-year (arg)
  88   "Move the cursor backward ARG years.
  89 Movement is forward is ARG is negative."
  90   (interactive "p")
  91   (calendar-forward-month (* -12 arg)))
  92
  93 ;;;###autoload
  94 (defun calendar-scroll-left (&optional arg event)
  95   "Scroll the displayed calendar left by ARG months.
  96 If ARG is negative the calendar is scrolled right.  Maintains the relative
  97 position of the cursor with respect to the calendar as well as possible."
  98   (interactive (list (prefix-numeric-value current-prefix-arg)
  99                      last-nonmenu-event))
 100   (unless arg (setq arg 1))
 101   (save-selected-window
 102     (select-window (posn-window (event-start event)))
 103     (calendar-cursor-to-nearest-date)
 104     (let ((old-date (calendar-cursor-to-date))
 105           (today (calendar-current-date)))
 106       (if (/= arg 0)
 107           (let ((month displayed-month)
 108                 (year displayed-year))
 109             (increment-calendar-month month year arg)
 110             (generate-calendar-window month year)
 111             (calendar-cursor-to-visible-date
 112              (cond
 113               ((calendar-date-is-visible-p old-date) old-date)
 114               ((calendar-date-is-visible-p today) today)
 115               (t (list month 1 year)))))))
 116     (run-hooks 'calendar-move-hook)))
 117
 118 ;;;###autoload
 119 (defun calendar-scroll-right (&optional arg event)
 120   "Scroll the displayed calendar window right by ARG months.
 121 If ARG is negative the calendar is scrolled left.  Maintains the relative
 122 position of the cursor with respect to the calendar as well as possible."
 123   (interactive (list (prefix-numeric-value current-prefix-arg)
 124                      last-nonmenu-event))
 125   (calendar-scroll-left (- (or arg 1)) event))
 126
 127 ;;;###autoload
 128 (defun calendar-scroll-left-three-months (arg)
 129   "Scroll the displayed calendar window left by 3*ARG months.
 130 If ARG is negative the calendar is scrolled right.  Maintains the relative
 131 position of the cursor with respect to the calendar as well as possible."
 132   (interactive "p")
 133   (calendar-scroll-left (* 3 arg)))
 134
 135 ;;;###autoload
 136 (defun calendar-scroll-right-three-months (arg)
 137   "Scroll the displayed calendar window right by 3*ARG months.
 138 If ARG is negative the calendar is scrolled left.  Maintains the relative
 139 position of the cursor with respect to the calendar as well as possible."
 140   (interactive "p")
 141   (calendar-scroll-left (* -3 arg)))
 142
 143 ;;;###autoload
 144 (defun calendar-cursor-to-nearest-date ()
 145   "Move the cursor to the closest date.
 146 The position of the cursor is unchanged if it is already on a date.
 147 Returns the list (month day year) giving the cursor position."
 148   (let ((date (calendar-cursor-to-date))
 149         (column (current-column)))
 150     (if date
 151         date
 152       (if (> 3 (count-lines (point-min) (point)))
 153           (progn
 154             (goto-line 3)
 155             (move-to-column column)))
 156       (if (not (looking-at "[0-9]"))
 157           (if (and (not (looking-at " *$"))
 158                    (or (< column 25)
 159                        (and (> column 27)
 160                             (< column 50))
 161                        (and (> column 52)
 162                             (< column 75))))
 163               (progn
 164                 (re-search-forward "[0-9]" nil t)
 165                 (backward-char 1))
 166             (re-search-backward "[0-9]" nil t)))
 167       (calendar-cursor-to-date))))
 168
 169 ;;;###autoload
 170 (defun calendar-forward-day (arg)
 171   "Move the cursor forward ARG days.
 172 Moves backward if ARG is negative."
 173   (interactive "p")
 174   (if (/= 0 arg)
 175       (let*
 176           ((cursor-date (calendar-cursor-to-date))
 177            (cursor-date (if cursor-date
 178                             cursor-date
 179                           (if (> arg 0) (setq arg (1- arg)))
 180                           (calendar-cursor-to-nearest-date)))
 181            (new-cursor-date
 182             (calendar-gregorian-from-absolute
 183              (+ (calendar-absolute-from-gregorian cursor-date) arg)))
 184            (new-display-month (extract-calendar-month new-cursor-date))
 185            (new-display-year (extract-calendar-year new-cursor-date)))
 186         ;; Put the new month on the screen, if needed, and go to the new date.
 187         (if (not (calendar-date-is-visible-p new-cursor-date))
 188             (calendar-other-month new-display-month new-display-year))
 189         (calendar-cursor-to-visible-date new-cursor-date)))
 190   (run-hooks 'calendar-move-hook))
 191
 192 ;;;###autoload
 193 (defun calendar-backward-day (arg)
 194   "Move the cursor back ARG days.
 195 Moves forward if ARG is negative."
 196   (interactive "p")
 197   (calendar-forward-day (- arg)))
 198
 199 ;;;###autoload
 200 (defun calendar-forward-week (arg)
 201   "Move the cursor forward ARG weeks.
 202 Moves backward if ARG is negative."
 203   (interactive "p")
 204   (calendar-forward-day (* arg 7)))
 205
 206 ;;;###autoload
 207 (defun calendar-backward-week (arg)
 208   "Move the cursor back ARG weeks.
 209 Moves forward if ARG is negative."
 210   (interactive "p")
 211   (calendar-forward-day (* arg -7)))
 212
 213 ;;;###autoload
 214 (defun calendar-beginning-of-week (arg)
 215   "Move the cursor back ARG calendar-week-start-day's."
 216   (interactive "p")
 217   (calendar-cursor-to-nearest-date)
 218   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 219     (calendar-backward-day
 220      (if (= day calendar-week-start-day)
 221          (* 7 arg)
 222        (+ (mod (- day calendar-week-start-day) 7)
 223           (* 7 (1- arg)))))))
 224
 225 ;;;###autoload
 226 (defun calendar-end-of-week (arg)
 227   "Move the cursor forward ARG calendar-week-start-day+6's."
 228   (interactive "p")
 229   (calendar-cursor-to-nearest-date)
 230   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 231     (calendar-forward-day
 232      (if (= day (mod (1- calendar-week-start-day) 7))
 233          (* 7 arg)
 234        (+ (- 6 (mod (- day calendar-week-start-day) 7))
 235           (* 7 (1- arg)))))))
 236
 237 ;;;###autoload
 238 (defun calendar-beginning-of-month (arg)
 239   "Move the cursor backward ARG month beginnings."
 240   (interactive "p")
 241   (calendar-cursor-to-nearest-date)
 242   (let* ((date (calendar-cursor-to-date))
 243          (month (extract-calendar-month date))
 244          (day (extract-calendar-day date))
 245          (year (extract-calendar-year date)))
 246     (if (= day 1)
 247         (calendar-backward-month arg)
 248       (calendar-cursor-to-visible-date (list month 1 year))
 249       (calendar-backward-month (1- arg)))))
 250
 251 ;;;###autoload
 252 (defun calendar-end-of-month (arg)
 253   "Move the cursor forward ARG month ends."
 254   (interactive "p")
 255   (calendar-cursor-to-nearest-date)
 256   (let* ((date (calendar-cursor-to-date))
 257          (month (extract-calendar-month date))
 258          (day (extract-calendar-day date))
 259          (year (extract-calendar-year date))
 260          (last-day (calendar-last-day-of-month month year)))
 261     (if (/= day last-day)
 262         (progn
 263           (calendar-cursor-to-visible-date (list month last-day year))
 264           (setq arg (1- arg))))
 265     (increment-calendar-month month year arg)
 266     (let ((last-day (list
 267                      month
 268                      (calendar-last-day-of-month month year)
 269                      year)))
 270       (if (not (calendar-date-is-visible-p last-day))
 271           (calendar-other-month month year)
 272       (calendar-cursor-to-visible-date last-day))))
 273   (run-hooks 'calendar-move-hook))
 274
 275 ;;;###autoload
 276 (defun calendar-beginning-of-year (arg)
 277   "Move the cursor backward ARG year beginnings."
 278   (interactive "p")
 279   (calendar-cursor-to-nearest-date)
 280   (let* ((date (calendar-cursor-to-date))
 281          (month (extract-calendar-month date))
 282          (day (extract-calendar-day date))
 283          (year (extract-calendar-year date))
 284          (jan-first (list 1 1 year))
 285          (calendar-move-hook nil))
 286     (if (and (= day 1) (= 1 month))
 287         (calendar-backward-month (* 12 arg))
 288       (if (and (= arg 1)
 289                (calendar-date-is-visible-p jan-first))
 290           (calendar-cursor-to-visible-date jan-first)
 291         (calendar-other-month 1 (- year (1- arg)))
 292         (calendar-cursor-to-visible-date (list 1 1 displayed-year)))))
 293   (run-hooks 'calendar-move-hook))
 294
 295 ;;;###autoload
 296 (defun calendar-end-of-year (arg)
 297   "Move the cursor forward ARG year beginnings."
 298   (interactive "p")
 299   (calendar-cursor-to-nearest-date)
 300   (let* ((date (calendar-cursor-to-date))
 301          (month (extract-calendar-month date))
 302          (day (extract-calendar-day date))
 303          (year (extract-calendar-year date))
 304          (dec-31 (list 12 31 year))
 305          (calendar-move-hook nil))
 306     (if (and (= day 31) (= 12 month))
 307         (calendar-forward-month (* 12 arg))
 308       (if (and (= arg 1)
 309                (calendar-date-is-visible-p dec-31))
 310           (calendar-cursor-to-visible-date dec-31)
 311         (calendar-other-month 12 (+ year (1- arg)))
 312         (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))
 313   (run-hooks 'calendar-move-hook))
 314
 315 ;;;###autoload
 316 (defun calendar-cursor-to-visible-date (date)
 317   "Move the cursor to DATE that is on the screen."
 318   (let* ((month (extract-calendar-month date))
 319          (day (extract-calendar-day date))
 320          (year (extract-calendar-year date))
 321          (first-of-month-weekday (calendar-day-of-week (list month 1 year))))
 322     (goto-line (+ 3
 323                   (/ (+ day  -1
 324                         (mod
 325                          (- (calendar-day-of-week (list month 1 year))
 326                             calendar-week-start-day)
 327                          7))
 328                      7)))
 329     (move-to-column (+ 6
 330                        (* 25
 331                           (1+ (calendar-interval
 332                                displayed-month displayed-year month year)))
 333                        (* 3 (mod
 334                              (- (calendar-day-of-week date)
 335                                 calendar-week-start-day)
 336                              7))))))
 337 ;;;###autoload
 338 (defun calendar-goto-date (date)
 339   "Move cursor to DATE."
 340   (interactive (list (calendar-read-date)))
 341   (let ((month (extract-calendar-month date))
 342         (year (extract-calendar-year date)))
 343     (if (not (calendar-date-is-visible-p date))
 344         (calendar-other-month
 345          (if (and (= month 1) (= year 1))
 346              2
 347            month)
 348          year)))
 349   (calendar-cursor-to-visible-date date)
 350   (run-hooks 'calendar-move-hook))
 351
 352 ;;;###autoload
 353 (defun calendar-goto-day-of-year (year day &optional noecho)
 354   "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is t.
 355 Negative DAY counts backward from end of year."
 356   (interactive
 357    (let* ((year (calendar-read
 358                  "Year (>0): "
 359                  (lambda (x) (> x 0))
 360                  (int-to-string (extract-calendar-year
 361                                  (calendar-current-date)))))
 362           (last (if (calendar-leap-year-p year) 366 365))
 363           (day (calendar-read
 364                 (format "Day number (+/- 1-%d): " last)
 365                 (lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
 366      (list year day)))
 367   (calendar-goto-date
 368    (calendar-gregorian-from-absolute
 369     (if (< 0 day)
 370         (+ -1 day (calendar-absolute-from-gregorian (list 1 1 year)))
 371       (+ 1 day (calendar-absolute-from-gregorian (list 12 31 year))))))
 372   (or noecho (calendar-print-day-of-year)))
 373
 374 ;; Backward compatibility.
 375 (define-obsolete-function-alias
 376   'scroll-calendar-left 'calendar-scroll-left "23.1")
 377 (define-obsolete-function-alias
 378   'scroll-calendar-right 'calendar-scroll-right "23.1")
 379 (define-obsolete-function-alias
 380   'scroll-calendar-left-three-months 'calendar-scroll-left-three-months "23.1")
 381 (define-obsolete-function-alias
 382   'scroll-calendar-right-three-months 'calendar-scroll-right-three-months "23.1")
 383
 384 (provide 'cal-move)
 385
 386 ;; Local Variables:
 387 ;; generated-autoload-file: "cal-loaddefs.el"
 388 ;; End:
 389
 390 ;; arch-tag: d0883c46-7e16-4914-8ff8-8f67e699b781
 391 ;;; cal-move.el ends here