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