lisp/calendar/cal-move.el

   1 ;;; cal-move.el --- calendar functions for movement in the calendar
   2
   3 ;; Copyright (C) 1995, 2005  Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Maintainer: Glenn Morris <gmorris@ast.cam.ac.uk>
   7 ;; Keywords: calendar
   8 ;; Human-Keywords: calendar
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This collection of functions implements movement in the calendar for
  30 ;; calendar.el.
  31
  32 ;; Comments, corrections, and improvements should be sent to
  33 ;;  Edward M. Reingold               Department of Computer Science
  34 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  35 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  36 ;;                                   Urbana, Illinois 61801
  37
  38 ;;; Code:
  39
  40 (defvar displayed-month)
  41 (defvar displayed-year)
  42
  43 (require 'calendar)
  44
  45 (defun calendar-goto-today ()
  46   "Reposition the calendar window so the current date is visible."
  47   (interactive)
  48   (let ((today (calendar-current-date)));; The date might have changed.
  49     (if (not (calendar-date-is-visible-p today))
  50         (generate-calendar-window)
  51       (update-calendar-mode-line)
  52       (calendar-cursor-to-visible-date today)))
  53   (run-hooks 'calendar-move-hook))
  54
  55 (defun calendar-forward-month (arg)
  56   "Move the cursor forward ARG months.
  57 Movement is backward if ARG is negative."
  58   (interactive "p")
  59   (calendar-cursor-to-nearest-date)
  60   (let* ((cursor-date (calendar-cursor-to-date t))
  61          (month (extract-calendar-month cursor-date))
  62          (day (extract-calendar-day cursor-date))
  63          (year (extract-calendar-year cursor-date)))
  64     (increment-calendar-month month year arg)
  65     (let ((last (calendar-last-day-of-month month year)))
  66       (if (< last day)
  67         (setq day last)))
  68     ;; Put the new month on the screen, if needed, and go to the new date.
  69     (let ((new-cursor-date (list month day year)))
  70       (if (not (calendar-date-is-visible-p new-cursor-date))
  71           (calendar-other-month month year))
  72       (calendar-cursor-to-visible-date new-cursor-date)))
  73   (run-hooks 'calendar-move-hook))
  74
  75 (defun calendar-forward-year (arg)
  76   "Move the cursor forward by ARG years.
  77 Movement is backward if ARG is negative."
  78   (interactive "p")
  79   (calendar-forward-month (* 12 arg)))
  80
  81 (defun calendar-backward-month (arg)
  82   "Move the cursor backward by ARG months.
  83 Movement is forward if ARG is negative."
  84   (interactive "p")
  85   (calendar-forward-month (- arg)))
  86
  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 (defun scroll-calendar-left (&optional arg)
  94   "Scroll the displayed calendar left by ARG months.
  95 If ARG is negative the calendar is scrolled right.  Maintains the relative
  96 position of the cursor with respect to the calendar as well as possible."
  97   (interactive "p")
  98   (unless arg (setq arg 1))
  99   (calendar-cursor-to-nearest-date)
 100   (let ((old-date (calendar-cursor-to-date))
 101         (today (calendar-current-date)))
 102     (if (/= arg 0)
 103         (let ((month displayed-month)
 104               (year displayed-year))
 105           (increment-calendar-month month year arg)
 106           (generate-calendar-window month year)
 107           (calendar-cursor-to-visible-date
 108            (cond
 109             ((calendar-date-is-visible-p old-date) old-date)
 110             ((calendar-date-is-visible-p today) today)
 111             (t (list month 1 year)))))))
 112   (run-hooks 'calendar-move-hook))
 113
 114 (defun scroll-calendar-right (&optional arg)
 115   "Scroll the displayed calendar window right by ARG months.
 116 If ARG is negative the calendar is scrolled left.  Maintains the relative
 117 position of the cursor with respect to the calendar as well as possible."
 118   (interactive "p")
 119   (scroll-calendar-left (- (or arg 1))))
 120
 121 (defun scroll-calendar-left-three-months (arg)
 122   "Scroll the displayed calendar window left by 3*ARG months.
 123 If ARG is negative the calendar is scrolled right.  Maintains the relative
 124 position of the cursor with respect to the calendar as well as possible."
 125   (interactive "p")
 126   (scroll-calendar-left (* 3 arg)))
 127
 128 (defun scroll-calendar-right-three-months (arg)
 129   "Scroll the displayed calendar window right by 3*ARG months.
 130 If ARG is negative the calendar is scrolled left.  Maintains the relative
 131 position of the cursor with respect to the calendar as well as possible."
 132   (interactive "p")
 133   (scroll-calendar-left (* -3 arg)))
 134
 135 (defun calendar-cursor-to-nearest-date ()
 136   "Move the cursor to the closest date.
 137 The position of the cursor is unchanged if it is already on a date.
 138 Returns the list (month day year) giving the cursor position."
 139   (let ((date (calendar-cursor-to-date))
 140         (column (current-column)))
 141     (if date
 142         date
 143       (if (> 3 (count-lines (point-min) (point)))
 144           (progn
 145             (goto-line 3)
 146             (move-to-column column)))
 147       (if (not (looking-at "[0-9]"))
 148           (if (and (not (looking-at " *$"))
 149                    (or (< column 25)
 150                        (and (> column 27)
 151                             (< column 50))
 152                        (and (> column 52)
 153                             (< column 75))))
 154               (progn
 155                 (re-search-forward "[0-9]" nil t)
 156                 (backward-char 1))
 157             (re-search-backward "[0-9]" nil t)))
 158       (calendar-cursor-to-date))))
 159
 160 (defun calendar-forward-day (arg)
 161   "Move the cursor forward ARG days.
 162 Moves backward if ARG is negative."
 163   (interactive "p")
 164   (if (/= 0 arg)
 165       (let*
 166           ((cursor-date (calendar-cursor-to-date))
 167            (cursor-date (if cursor-date
 168                             cursor-date
 169                           (if (> arg 0) (setq arg (1- arg)))
 170                           (calendar-cursor-to-nearest-date)))
 171            (new-cursor-date
 172             (calendar-gregorian-from-absolute
 173              (+ (calendar-absolute-from-gregorian cursor-date) arg)))
 174            (new-display-month (extract-calendar-month new-cursor-date))
 175            (new-display-year (extract-calendar-year new-cursor-date)))
 176         ;; Put the new month on the screen, if needed, and go to the new date.
 177         (if (not (calendar-date-is-visible-p new-cursor-date))
 178             (calendar-other-month new-display-month new-display-year))
 179         (calendar-cursor-to-visible-date new-cursor-date)))
 180   (run-hooks 'calendar-move-hook))
 181
 182 (defun calendar-backward-day (arg)
 183   "Move the cursor back ARG days.
 184 Moves forward if ARG is negative."
 185   (interactive "p")
 186   (calendar-forward-day (- arg)))
 187
 188 (defun calendar-forward-week (arg)
 189   "Move the cursor forward ARG weeks.
 190 Moves backward if ARG is negative."
 191   (interactive "p")
 192   (calendar-forward-day (* arg 7)))
 193
 194 (defun calendar-backward-week (arg)
 195   "Move the cursor back ARG weeks.
 196 Moves forward if ARG is negative."
 197   (interactive "p")
 198   (calendar-forward-day (* arg -7)))
 199
 200 (defun calendar-beginning-of-week (arg)
 201   "Move the cursor back ARG calendar-week-start-day's."
 202   (interactive "p")
 203   (calendar-cursor-to-nearest-date)
 204   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 205     (calendar-backward-day
 206      (if (= day calendar-week-start-day)
 207          (* 7 arg)
 208        (+ (mod (- day calendar-week-start-day) 7)
 209           (* 7 (1- arg)))))))
 210
 211 (defun calendar-end-of-week (arg)
 212   "Move the cursor forward ARG calendar-week-start-day+6's."
 213   (interactive "p")
 214   (calendar-cursor-to-nearest-date)
 215   (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
 216     (calendar-forward-day
 217      (if (= day (mod (1- calendar-week-start-day) 7))
 218          (* 7 arg)
 219        (+ (- 6 (mod (- day calendar-week-start-day) 7))
 220           (* 7 (1- arg)))))))
 221
 222 (defun calendar-beginning-of-month (arg)
 223   "Move the cursor backward ARG month beginnings."
 224   (interactive "p")
 225   (calendar-cursor-to-nearest-date)
 226   (let* ((date (calendar-cursor-to-date))
 227          (month (extract-calendar-month date))
 228          (day (extract-calendar-day date))
 229          (year (extract-calendar-year date)))
 230     (if (= day 1)
 231         (calendar-backward-month arg)
 232       (calendar-cursor-to-visible-date (list month 1 year))
 233       (calendar-backward-month (1- arg)))))
 234
 235 (defun calendar-end-of-month (arg)
 236   "Move the cursor forward ARG month ends."
 237   (interactive "p")
 238   (calendar-cursor-to-nearest-date)
 239   (let* ((date (calendar-cursor-to-date))
 240          (month (extract-calendar-month date))
 241          (day (extract-calendar-day date))
 242          (year (extract-calendar-year date))
 243          (last-day (calendar-last-day-of-month month year)))
 244     (if (/= day last-day)
 245         (progn
 246           (calendar-cursor-to-visible-date (list month last-day year))
 247           (setq arg (1- arg))))
 248     (increment-calendar-month month year arg)
 249     (let ((last-day (list
 250                      month
 251                      (calendar-last-day-of-month month year)
 252                      year)))
 253       (if (not (calendar-date-is-visible-p last-day))
 254           (calendar-other-month month year)
 255       (calendar-cursor-to-visible-date last-day))))
 256   (run-hooks 'calendar-move-hook))
 257
 258 (defun calendar-beginning-of-year (arg)
 259   "Move the cursor backward ARG year beginnings."
 260   (interactive "p")
 261   (calendar-cursor-to-nearest-date)
 262   (let* ((date (calendar-cursor-to-date))
 263          (month (extract-calendar-month date))
 264          (day (extract-calendar-day date))
 265          (year (extract-calendar-year date))
 266          (jan-first (list 1 1 year))
 267          (calendar-move-hook nil))
 268     (if (and (= day 1) (= 1 month))
 269         (calendar-backward-month (* 12 arg))
 270       (if (and (= arg 1)
 271                (calendar-date-is-visible-p jan-first))
 272           (calendar-cursor-to-visible-date jan-first)
 273         (calendar-other-month 1 (- year (1- arg)))
 274         (calendar-cursor-to-visible-date (list 1 1 displayed-year)))))
 275   (run-hooks 'calendar-move-hook))
 276
 277 (defun calendar-end-of-year (arg)
 278   "Move the cursor forward ARG year beginnings."
 279   (interactive "p")
 280   (calendar-cursor-to-nearest-date)
 281   (let* ((date (calendar-cursor-to-date))
 282          (month (extract-calendar-month date))
 283          (day (extract-calendar-day date))
 284          (year (extract-calendar-year date))
 285          (dec-31 (list 12 31 year))
 286          (calendar-move-hook nil))
 287     (if (and (= day 31) (= 12 month))
 288         (calendar-forward-month (* 12 arg))
 289       (if (and (= arg 1)
 290                (calendar-date-is-visible-p dec-31))
 291           (calendar-cursor-to-visible-date dec-31)
 292         (calendar-other-month 12 (+ year (1- arg)))
 293         (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))
 294   (run-hooks 'calendar-move-hook))
 295
 296 (defun calendar-cursor-to-visible-date (date)
 297   "Move the cursor to DATE that is on the screen."
 298   (let* ((month (extract-calendar-month date))
 299          (day (extract-calendar-day date))
 300          (year (extract-calendar-year date))
 301          (first-of-month-weekday (calendar-day-of-week (list month 1 year))))
 302     (goto-line (+ 3
 303                   (/ (+ day  -1
 304                         (mod
 305                          (- (calendar-day-of-week (list month 1 year))
 306                             calendar-week-start-day)
 307                          7))
 308                      7)))
 309     (move-to-column (+ 6
 310                        (* 25
 311                           (1+ (calendar-interval
 312                                displayed-month displayed-year month year)))
 313                        (* 3 (mod
 314                              (- (calendar-day-of-week date)
 315                                 calendar-week-start-day)
 316                              7))))))
 317
 318 (defun calendar-goto-date (date)
 319   "Move cursor to DATE."
 320   (interactive (list (calendar-read-date)))
 321   (let ((month (extract-calendar-month date))
 322         (year (extract-calendar-year date)))
 323     (if (not (calendar-date-is-visible-p date))
 324         (calendar-other-month
 325          (if (and (= month 1) (= year 1))
 326              2
 327            month)
 328          year)))
 329   (calendar-cursor-to-visible-date date)
 330   (run-hooks 'calendar-move-hook))
 331
 332 (defun calendar-goto-day-of-year (year day &optional noecho)
 333   "Move cursor to YEAR, DAY number; echo DAY/YEAR unless NOECHO is t.
 334 Negative DAY counts backward from end of year."
 335   (interactive
 336    (let* ((year (calendar-read
 337                  "Year (>0): "
 338                  (lambda (x) (> x 0))
 339                  (int-to-string (extract-calendar-year
 340                                  (calendar-current-date)))))
 341           (last (if (calendar-leap-year-p year) 366 365))
 342           (day (calendar-read
 343                 (format "Day number (+/- 1-%d): " last)
 344                 '(lambda (x) (and (<= 1 (abs x)) (<= (abs x) last))))))
 345      (list year day)))
 346   (calendar-goto-date
 347    (calendar-gregorian-from-absolute
 348     (if (< 0 day)
 349         (+ -1 day (calendar-absolute-from-gregorian (list 1 1 year)))
 350       (+ 1 day (calendar-absolute-from-gregorian (list 12 31 year))))))
 351   (or noecho (calendar-print-day-of-year)))
 352
 353 (provide 'cal-move)
 354
 355 ;;; arch-tag: d0883c46-7e16-4914-8ff8-8f67e699b781
 356 ;;; cal-move.el ends here