🚀 go-pugleaf

Thanks to all the many folks who responded to my request!  A number of bugs
were uncovered and suggestions made.  Here is a MUCH improved version that
includes proper marking of the current date in the window (even when it's
not the middle month), friendlier window treatment (i hope!), it's own major
mode so as not to screw up key bindings, and the ability to accept months
and years (directly) for display with the o command.

Again, I'd be grateful to anyone willing to play with it for a while to find
bugs or make suggestions for improvements.

----------------------------------------------------------------------------
;; Record version number of Emacs.
;; Copyright (C) 1988, 1989 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;;
;; Comments, corrections, and improvements should be sent to
;;  Edward M. Reingold               Department of Computer Science
;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
;;  reingold@a.cs.uiuc.edu           1304 West Springfield Avenue
;;                                   Urbana, Illinois 61801
;;
;; The author gratefully acknowledges the patient help of Richard Stallman
;; in making this function into a reasonable piece of code!
;;
;; Modification for month-offset arguments suggested and implemented by
;;  Constantine Rasmussen            Sun Microsystems, East Coast Division
;;  (617) 671-0404                   2 Federal Street;  Billerica, Ma.  01824
;;  ARPA: cdr@sun.com   USENET: {cbosgd,decvax,hplabs,seismo}!sun!suneast!cdr
;;
;; Modification to mark current day with stars suggested by
;;  Franklin Davis		     Thinking Machines Corp
;;  (617) 876-1111                   245 First Street, Cambridge, MA  02142
;;  fad@think.com
;;
;; Minor corrections made and code added for an 'infinite' calendar window
;; by E.M.R., January 4, 1989.  GNU Emacs users to numerous to list pointed
;; out a variety of problems with an earlier form of the 'infinite' calendar.
;;

(defvar today-visible-calendar-hook nil
  "List of functions called after the calendar buffer has been prepared
with the calendar when the current date is visible in the window.  This can
be used, for example, to highlight today's date with asterisks--a function
star-date is included for this purpose.  The variable
today-invisible-calendar-hook is the list of functions called when the
calendar function was called when the current date is not visible in the
window.")

(defvar today-invisible-calendar-hook nil
  "List of functions called after the calendar buffer has been prepared
with the calendar when the current date is not visible in the window.  The
variable today-visible-calendar-hook is the list of functions called when
the calendar function was called when the current date is visible in the
window.")

(defun calendar-help ()
  "Give a description of key-bindings in the calendar window."
  (interactive)
  (message
   ". backward a month  , forward a month  c current month  o other month  e exit"))

(defun calendar (&optional month-offset)
  "Display a three-month calendar in another window.
The three months appear side by side, with the current month in the middle
surrounded by the previous and next months.  The cursor is put on today's date.
Future months can be moved into view with ','; prior months can be moved into
view with '.'.

An optional prefix argument MONTH-OFFSET causes the calendar displayed to
be MONTH-OFFSET months in the future if MONTH-OFFSET is positive or in the
past if MONTH-OFFSET is negative; in this case the cursor goes on the first
day of the month.

The Gregorian calendar is assumed.

After preparing the calendar window, the hooks today-visible-calendar-hook
are run when the current date is visible in the window.  If it is not
visible, the hooks today-invisible-calendar-hook are run.  Thus, for
example, setting today-visible-calendar-hook to 'star-date will cause
today's date to be replaced by asterisks to highlight it in the window."

  (interactive "P")
  (let ((today (make-marker)))
    (save-excursion
      (set-buffer (get-buffer-create "*Calendar*"))
      (calendar-mode)
      (setq calendar-entry-configuration (current-window-configuration))
      (let* ((buffer-read-only nil)
             ;; Get today's date and extract the day, month and year.
             (date (current-time-string))
             (garbage (string-match
                       "^\\([A-Z][a-z]*\\) *\\([A-Z][a-z]*\\) *\\([0-9]*\\) .* \\([0-9]*\\)$"
                       date))
             (day-in-the-week
                (substring date (match-beginning 1) (match-end 1)))
             (month (substring date (match-beginning 2) (match-end 2)))
             (day-in-the-month
                (substring date (match-beginning 3) (match-end 3)))
             (year (substring date (match-beginning 4) (match-end 4)))
             (date-string
                (concat day-in-the-week ", "
                        month " " day-in-the-month ", " year)))
        (setq mode-line-format
              (format
                 "--period->   Calendar   e exit/o other/c current  %17s   <-comma--"
                 date-string))
        (erase-buffer)
        (setq current-month
              (cdr (assoc month
                        '(("Jan" . 1) ("Feb" . 2)  ("Mar" . 3)  ("Apr" . 4)
                         ("May" . 5) ("Jun" . 6)  ("Jul" . 7)  ("Aug" . 8)
                         ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
        (setq current-year (string-to-int year))
        (setq displayed-month current-month)
        (setq displayed-year current-year)
        (setq month-offset
              (if month-offset
                  (prefix-numeric-value month-offset)
                  0))
        (increment-month 'displayed-month 'displayed-year month-offset)
        (let ((i-month displayed-month)
              (i-year displayed-year)
              (i -1)
              (day (if (and (> 2  month-offset)
                            (< -2 month-offset))
                       (string-to-int day-in-the-month)))
              (c-month (1+ (interval displayed-month displayed-year
                                     current-month current-year))))
          (increment-month 'i-month 'i-year -2)
          ;; Generate the three-month window.
          (while (>= 2 (setq i (1+ i)))
            (increment-month 'i-month 'i-year 1)
            ;; Generate the month--record where today's date appears
            ;; in the marker TODAY.
            (if (= i c-month)
                (set-marker today
                            (generate-month i-month i-year (* 24 i) day))
                (generate-month i-month i-year (* 24 i)))))))
    ;; Display the buffer and put cursor on today's date.  Do it in another
    ;; window, but if this buffer is already visible, just select its window.
    (pop-to-buffer "*Calendar*")
    (goto-char (or (marker-position today)
                   (point-min)))
    ;; Make TODAY point nowhere so it won't slow down buffer editing until GC.
    (set-marker today nil))
  (or (one-window-p t)
      (shrink-window (- (window-height) 9)))
  (if (or (< 2  month-offset)
          (> -2 month-offset))
      (run-hooks 'today-invisible-calendar-hook)
      (run-hooks 'today-visible-calendar-hook)))

(defvar calendar-mode-map nil)

(if calendar-mode-map
    nil
    (setq calendar-mode-map (make-sparse-keymap))
    (define-key calendar-mode-map "." 'backward-month)
    (define-key calendar-mode-map "," 'forward-month)
    (define-key calendar-mode-map "c" 'show-current-month)
    (define-key calendar-mode-map "o" 'show-other-month)
    (define-key calendar-mode-map "e" 'exit-calendar)
    (define-key calendar-mode-map "?" 'calendar-help))

(defun calendar-mode ()
  "A major mode for the calendar window."
  (kill-all-local-variables)
  (setq major-mode 'calendar-mode)
  (setq mode-name "Calendar")
  (use-local-map calendar-mode-map)
  (setq buffer-read-only t)
  (make-local-variable 'calendar-entry-configuration)
  (make-local-variable 'mode-line-format)
  (make-local-variable 'current-month)  ;;  Current month.
  (make-local-variable 'current-year)   ;;  Current year.
  (make-local-variable 'displayed-month);;  Month in middle of window.
  (make-local-variable 'displayed-year));;  Year in middle of window.

(defun increment-month (mon yr n)
  "Move the variables MON and YR to the month and year N months forward
if N is positive or backward if N is negative."
  (let ((y (+ (+ (* (eval yr) 12) (- (eval mon) 1)) n)))
    (set mon (+ (% y 12) 1))
    (set yr (/ y 12))))

(defun exit-calendar ()
  "Get out of the calendar window and destroy it."
  (interactive)
  (set-window-configuration calendar-entry-configuration)
  (kill-buffer "*Calendar*"))

(defun show-current-month ()
  "Reposition the calendar window so the original request is visible."
  (interactive)
  (calendar))

(defun forward-month (&optional arg)
  "Advance the displayed calendar window by one month.
An optional prefix argument ARG causes the calendar to be advanced by
ARG months if ARG is positive or to be moved backward if ARG is negative."
  (interactive "p")
  (calendar (+ arg 
               (interval current-month current-year
                         displayed-month displayed-year))))

(defun backward-month (&optional arg)
  "Move the displayed calendar window backward by one month.
An optional prefix argument ARG causes the calendar to be move backward
by ARG months if ARG is positive or to be advanced if ARG is negative."
  (interactive "p")
  (forward-month (- arg)))

(defun show-other-month (month year)
  "Display a three-month calendar centered around MONTH and YEAR."
  (interactive "nMonth (1-12): \nnYear (>0): ")
  (if (or (< 12 month) (> 1 month) (> 1 year))
      (error "Unintelligible month/year!"))
  (calendar (interval current-month current-year month year)))

(defun last-line-p ()
  "Returns true if point is on the last line of the buffer."
  (save-excursion
    (end-of-line)
    (eobp)))

(defun interval (mon1 yr1 mon2 yr2)
  "The number of months difference between the two specified months."
  (+ (* 12 (- yr2 yr1))
     (- mon2 mon1)))

(defun leap-year-p (year)
  "Returns true if YEAR is a Gregorian leap year, and false if not."
  (or
    (and (=  (% year   4) 0)
         (/= (% year 100) 0))
    (= (% year 400) 0)))

(defun day-number (month day year)
  "Return day-number within year (origin-1) of the date MONTH DAY YEAR.
For example, (day-number 1 1 1987) returns the value 1,
while (day-number 12 31 1980) returns 366."
;;
;; An explanation of the calculation can be found in PascAlgorithms by
;; Edward and Ruth Reingold, Scott-foresman/Little, Brown, 1988.
;;
  (let ((day-of-year (+ day (* 31 (1- month)))))
    (if (> month 2)
        (progn
          (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
          (if (leap-year-p year)
              (setq day-of-year (1+ day-of-year)))))
    day-of-year))

(defun day-of-week (month day year)
  "Returns the day-of-the-week index of MONTH DAY, YEAR.
Value is 0 for Sunday, 1 for Monday, etc."
;;
;; Done by calculating the number of days elapsed since the (imaginary)
;; Gregorian date Sunday, December 31, 1 BC and taking that number mod 7.
;;
  (%
    (-
      (+ (day-number month day year)
         (* 365 (1- year))
         (/ (1- year) 4))
      (let ((correction (* (/ (1- year) 100) 3)))
        (if (= (% correction 4) 0)
            (/ correction 4)
            (1+ (/ correction 4)))))
    7))

(defun generate-month (month year indent &optional day)
  "Produce a calendar for MONTH, YEAR on the Gregorian calendar, inserted
in the buffer starting at the line on which point is currently located, but
indented INDENT spaces.  The position in the buffer of the optional
parameter DAY is returned.  The indentation is done from the first
character on the line and does not disturb the first INDENT characters on
the line.

Each month is 7 days wide and 6 weeks high and is followed by 4 spaces."

  (let* ((first-day-of-month (day-of-week month 1 year))
         (first-saturday (- 7 first-day-of-month))
         (last-of-month
           (if (and (leap-year-p year) (= month 2))
               29
               (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
         (month-name
           (aref ["January" "February" "March" "April" "May" "June"
                  "July" "August" "September" "October" "November" "December"]
                  (1- month)))
         (buffer-read-only nil))
    (save-excursion
      (goto-char (point-min))
      (let ((title-line (format "   %s %d" month-name year)))
        (insert-indented  ;;   Force title line to be correct width.
         (format
          (concat "%" (int-to-string (- 24 (length title-line))) "s") "")
         indent)
        (insert-indented title-line indent t))
      (insert-indented " S  M Tu  W Th  F  S    " indent t)
      (insert-indented "" indent);; Move point to appropriate spot on line.
        (let ((i (- first-day-of-month))
            (day-marker))
          (while (<= (setq i (1+ i)) 42)       ;; Put in the days of the month.
            (if (and (<= 1 i) (>= last-of-month i))
                (insert (format "%2d " i))
                (insert "   "))
            (and day (= i day)  ;; Save the location of the specified day.
                 (setq day-marker (- (point) 2)))
            (and (= (% i 7) (% first-saturday 7))
                 (progn (insert "   ") t)        ;; Separate from next month.
                 (insert-indented "" 0 t)        ;; Force onto following line.
                 (insert-indented "" indent)))   ;; Go to proper spot on line.
          (set-buffer-modified-p nil)
          day-marker))))


(defun insert-indented (string indent &optional newline)
  "Insert STRING at column INDENT.
If the optional parameter NEWLINE is true, leave point at start of next
line, inserting a newline if there was no next line; otherwise, leave point
after the inserted text.  Value is always `t'."
  ;; Try to move to that column.
  (move-to-column indent)
  ;; If line is too short, indent out to that column.
  (if (< (current-column) indent)
      (indent-to indent))
  (insert string)
  ;; Advance to next line, if requested.
  (if newline
      (progn
	(end-of-line)
	(if (eobp)
            (newline)
	  (forward-line 1))))
  t)

(defun star-date ()
  "Replace today's date with asterisks in the calendar window.
This function can be used with the calendar-hook run after the
calendar window has been prepared."
  (let ((buffer-read-only nil))
    (forward-char 1)
    (delete-backward-char 2)
    (insert "**")
    (backward-char 1)))