Return to cal.el CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp

Annotation of 43BSDReno/contrib/emacs-18.55/lisp/cal.el, revision 1.1

1.1     ! root        1: ;; Record version number of Emacs.
        !             2: ;; Copyright (C) 1988 Free Software Foundation, Inc.
        !             3: 
        !             4: ;; This file is part of GNU Emacs.
        !             5: 
        !             6: ;; GNU Emacs is distributed in the hope that it will be useful,
        !             7: ;; but WITHOUT ANY WARRANTY.  No author or distributor
        !             8: ;; accepts responsibility to anyone for the consequences of using it
        !             9: ;; or for whether it serves any particular purpose or works at all,
        !            10: ;; unless he says so in writing.  Refer to the GNU Emacs General Public
        !            11: ;; License for full details.
        !            12: 
        !            13: ;; Everyone is granted permission to copy, modify and redistribute
        !            14: ;; GNU Emacs, but only under the conditions described in the
        !            15: ;; GNU Emacs General Public License.   A copy of this license is
        !            16: ;; supposed to have been given to you along with GNU Emacs so you
        !            17: ;; can know your rights and responsibilities.  It should be in a
        !            18: ;; file named COPYING.  Among other things, the copyright notice
        !            19: ;; and this notice must be preserved on all copies.
        !            20: ;;
        !            21: ;; Comments, corrections, and improvements should be sent to
        !            22: ;;  Edward M. Reingold               Department of Computer Science
        !            23: ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
        !            24: ;;  [email protected]           1304 West Springfield Avenue
        !            25: ;;                                   Urbana, Illinois 61801
        !            26: ;;
        !            27: ;; The author gratefully acknowledges the patient help of Richard Stallman
        !            28: ;; in making this function into a reasonable piece of code!
        !            29: ;;
        !            30: ;; Modification for month-offset arguments suggested and implemented by
        !            31: ;;  Constantine Rasmussen            Sun Microsystems, East Coast Division
        !            32: ;;  (617) 671-0404                   2 Federal Street;  Billerica, Ma.  01824
        !            33: ;;  ARPA: [email protected]   USENET: {cbosgd,decvax,hplabs,seismo}!sun!suneast!cdr
        !            34: ;;
        !            35: ;; Modification to mark current day with stars suggested by
        !            36: ;;  Franklin Davis                  Thinking Machines Corp
        !            37: ;;  (617) 876-1111                   245 First Street, Cambridge, MA  02142
        !            38: ;;  [email protected]
        !            39: 
        !            40: (defvar calendar-hook nil
        !            41:   "List of functions called after the calendar buffer has been prepared with
        !            42: the calendar of the current month.  This can be used, for example, to highlight
        !            43: today's date with asterisks--a function star-date is included for this purpose.
        !            44: The variable offset-calendar-hook is the list of functions called when the
        !            45: calendar function was called for a past or future month.")
        !            46: 
        !            47: (defvar offset-calendar-hook nil
        !            48:   "List of functions called after the calendar buffer has been prepared with
        !            49: the calendar of a past or future month.  The variable calendar-hook is the
        !            50: list of functions called when the calendar function was called for the
        !            51: current month.")
        !            52: 
        !            53: (defun calendar (&optional month-offset)
        !            54:   "Display three-month calendar in another window.
        !            55: The three months appear side by side, with the current month in the middle
        !            56: surrounded by the previous and next months.  The cursor is put on today's date.
        !            57: 
        !            58: An optional prefix argument ARG causes the calendar displayed to be
        !            59: ARG months in the future if ARG is positive or in the past if ARG is
        !            60: negative; in this case the cursor goes on the first day of the month.
        !            61: 
        !            62: The Gregorian calendar is assumed.
        !            63: 
        !            64: After preparing the calendar window, the hooks calendar-hook are run
        !            65: when the calendar is for the current month--that is, the was no prefix
        !            66: argument.  If the calendar is for a future or past month--that is, there
        !            67: was a prefix argument--the hooks offset-calendar-hook are run.  Thus, for
        !            68: example, setting calendar-hooks to 'star-date will cause today's date to be
        !            69: replaced by asterisks to highlight it in the window."
        !            70:   (interactive "P")
        !            71:   (if month-offset (setq month-offset (prefix-numeric-value month-offset)))
        !            72:   (let ((today (make-marker)))
        !            73:     (save-excursion
        !            74:       (set-buffer (get-buffer-create "*Calendar*"))
        !            75:       (setq buffer-read-only t)
        !            76:       (let*
        !            77:          ((buffer-read-only nil)
        !            78:           ;; Get today's date and extract the day, month and year.
        !            79:           (date (current-time-string))
        !            80:           (garbage (string-match
        !            81:                      " \\([A-Z][a-z][a-z]\\) *\\([0-9]*\\) .* \\([0-9]*\\)$"
        !            82:                      date))
        !            83:           (day (or (and month-offset 1) 
        !            84:                    (string-to-int
        !            85:                      (substring date (match-beginning 2) (match-end 2)))))
        !            86:           (month
        !            87:             (cdr (assoc
        !            88:                     (substring date (match-beginning 1) (match-end 1))
        !            89:                     '(("Jan" . 1) ("Feb" . 2)  ("Mar" . 3)  ("Apr" . 4)
        !            90:                       ("May" . 5) ("Jun" . 6)  ("Jul" . 7)  ("Aug" . 8)
        !            91:                       ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
        !            92:           (year (string-to-int
        !            93:                   (substring date (match-beginning 3) (match-end 3)))))
        !            94:        (erase-buffer)
        !            95:        ;; If user requested a month in the future or the past,
        !            96:        ;; advance the variables MONTH and YEAR to describe that one.
        !            97:        (cond
        !            98:           (month-offset
        !            99:             (let ((year-month (+ (+ (* year 12) (- month 1)) month-offset)))
        !           100:               (setq month (+ (% year-month 12) 1))
        !           101:               (setq year (/ year-month 12)))))
        !           102:        ;; Generate previous month, starting at left margin.
        !           103:        (generate-month;; previous month
        !           104:          (if (= month 1) 12 (1- month))
        !           105:          (if (= month 1) (1- year) year)
        !           106:          0)
        !           107:        ;; Generate this month, starting at column 24,
        !           108:        ;; and record where today's date appears, in the marker TODAY.
        !           109:        (goto-char (point-min))
        !           110:        (set-marker today (generate-month month year 24 day))
        !           111:        ;; Generate the following month, starting at column 48.
        !           112:        (goto-char (point-min))
        !           113:        (generate-month
        !           114:          (if (= month 12) 1 (1+ month))
        !           115:          (if (= month 12) (1+ year) year)
        !           116:          48)))
        !           117:     ;; Display the buffer and put cursor on today's date.
        !           118:     ;; Do it in another window, but if this buffer is already visible,
        !           119:     ;; just select its window.
        !           120:     (pop-to-buffer "*Calendar*")
        !           121:     (goto-char (marker-position today))
        !           122:     ;; Make TODAY point nowhere so it won't slow down buffer editing until GC.
        !           123:     (set-marker today nil))
        !           124:   ;; Make the window just tall enough for its contents.
        !           125:   (let ((h (1- (window-height)))
        !           126:         (l (count-lines (point-min) (point-max))))
        !           127:     (or (one-window-p t)
        !           128:         (<= h l)
        !           129:         (shrink-window (- h l))))
        !           130:   (if month-offset
        !           131:       (run-hooks 'offset-calendar-hook)
        !           132:       (run-hooks 'calendar-hook)))
        !           133: 
        !           134: (defun leap-year-p (year)
        !           135:   "Returns true if YEAR is a Gregorian leap year, and false if not."
        !           136:   (or
        !           137:     (and (=  (% year   4) 0)
        !           138:          (/= (% year 100) 0))
        !           139:     (= (% year 400) 0)))
        !           140: 
        !           141: (defun day-number (month day year)
        !           142:   "Return day-number within year (origin-1) of the date MONTH DAY YEAR.
        !           143: For example, (day-number 1 1 1987) returns the value 1,
        !           144: while (day-number 12 31 1980) returns 366."
        !           145: ;;
        !           146: ;; an explanation of the calculation can be found in PascAlgorithms by
        !           147: ;; Edward and Ruth Reingold, Scott-foresman/Little, Brown, 1988.
        !           148: ;;
        !           149:   (let ((day-of-year (+ day (* 31 (1- month)))))
        !           150:     (if (> month 2)
        !           151:         (progn
        !           152:           (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
        !           153:           (if (leap-year-p year)
        !           154:               (setq day-of-year (1+ day-of-year)))))
        !           155:     day-of-year))
        !           156: 
        !           157: (defun day-of-week (month day year)
        !           158:   "Returns the day-of-the-week index of MONTH DAY, YEAR.
        !           159: Value is 0 for Sunday, 1 for Monday, etc."
        !           160: ;;
        !           161: ;; Done by calculating the number of days elapsed since the (imaginary)
        !           162: ;; Gregorian date Sunday, December 31, 1 BC and taking that number mod 7.
        !           163: ;;
        !           164:   (%
        !           165:     (-
        !           166:       (+ (day-number month day year)
        !           167:          (* 365 (1- year))
        !           168:          (/ (1- year) 4))
        !           169:       (let ((correction (* (/ (1- year) 100) 3)))
        !           170:         (if (= (% correction 4) 0)
        !           171:             (/ correction 4)
        !           172:             (1+ (/ correction 4)))))
        !           173:     7))
        !           174: 
        !           175: (defun generate-month (month year indent &optional day)
        !           176:   "Produce a calendar for MONTH, YEAR on the Gregorian calendar, inserted
        !           177: in the buffer starting at the line on which point is currently located, but
        !           178: indented INDENT spaces.  The position in the buffer of the optional
        !           179: parameter DAY is returned.  The indentation is done from the first
        !           180: character on the line and does not disturb the first INDENT characters on
        !           181: the line."
        !           182:   (let* ((first-day-of-month (day-of-week month 1 year) 7)
        !           183:          (first-saturday (- 7 first-day-of-month))
        !           184:          (last-of-month
        !           185:            (if (and (leap-year-p year) (= month 2))
        !           186:                29
        !           187:                (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
        !           188:          (month-name
        !           189:            (aref ["January" "February" "March" "April" "May" "June"
        !           190:                   "July" "August" "September" "October" "November" "December"]
        !           191:                   (1- month))))
        !           192:     (insert-indented (format "   %s %d" month-name year) indent t)
        !           193:     (insert-indented " S  M Tu  W Th  F  S" indent t)
        !           194:     (insert-indented "" indent);; move point to appropriate spot on line
        !           195:     (let ((i 0))               ;; add blank days before the first of the month
        !           196:       (while (<= (setq i (1+ i)) first-day-of-month)
        !           197:         (insert "   ")))
        !           198:     (let ((i 0)
        !           199:           (day-marker))        ;; put in the days of the month
        !           200:       (while (<= (setq i (1+ i)) last-of-month)
        !           201:         (insert (format "%2d " i))
        !           202:         (and
        !           203:           day
        !           204:           (= i day)            ;; save the location of the specified day
        !           205:           (setq day-marker (- (point) 2)))
        !           206:         (and (= (% i 7) (% first-saturday 7))
        !           207:              (/= i last-of-month)
        !           208:              (insert-indented "" 0 t)        ;; force onto following line
        !           209:              (insert-indented "" indent)))   ;; go to proper spot on line
        !           210:       day-marker)))
        !           211: 
        !           212: (defun insert-indented (string indent &optional newline)
        !           213:   "Insert STRING at column INDENT.
        !           214: If the optional parameter NEWLINE is true, leave point at start of next
        !           215: line, inserting a newline if there was no next line; otherwise, leave point
        !           216: after the inserted text.  Value is always `t'."
        !           217:   ;; Try to move to that column.
        !           218:   (move-to-column indent)
        !           219:   ;; If line is too short, indent out to that column.
        !           220:   (if (< (current-column) indent)
        !           221:       (indent-to indent))
        !           222:   (insert string)
        !           223:   ;; Advance to next line, if requested.
        !           224:   (if newline
        !           225:       (progn
        !           226:        (end-of-line)
        !           227:        (if (eobp)
        !           228:             (newline)
        !           229:          (forward-line 1))))
        !           230:   t)
        !           231: 
        !           232: (defun star-date ()
        !           233:   "Replace today's date with asterisks in the calendar window.
        !           234: This function can be used with the calendar-hook run after the
        !           235: calendar window has been prepared."
        !           236:   (let ((buffer-read-only nil))
        !           237:     (forward-char 1)
        !           238:     (delete-backward-char 2)
        !           239:     (insert "**")
        !           240:     (backward-char 1)))
        !           241: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.