Return to cal.el CVS log

Up to [Apple XNU] / GNUtools / emacs / lisp

Annotation of GNUtools/emacs/lisp/cal.el, revision 1.1

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

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