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