Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!uunet!seismo!sundc!pitstop!sun!amdcad!ames!hc!beta!cmcl2!rutgers!iuvax!pur-ee!uiucdcs!uiucdcsp!reingold
From: reingold@uiucdcsp.cs.uiuc.edu
Newsgroups: comp.emacs
Subject: Re: Calendar Window
Message-ID: <77000003@uiucdcsp>
Date: Wed, 4-Nov-87 11:03:00 EST
Article-I.D.: uiucdcsp.77000003
Posted: Wed Nov  4 11:03:00 1987
Date-Received: Sun, 8-Nov-87 00:55:25 EST
References: <77000002@uiucdcsp>
Lines: 130
Nf-ID: #R:uiucdcsp:77000002:uiucdcsp:77000003:000:5020
Nf-From: uiucdcsp.cs.uiuc.edu!reingold    Nov  4 10:03:00 1987


I have been (correctly) criticized for not including the usual right-of-use
notice and author information at the front of the calendar-window function.
Mea culpa!  Here is the augmented version, containing a very minor
improvement--the window is shrunk to size, when appropriate.

If this function becomes part of the GNU Emacs distribution, I'd be delighted!

---------------------------------cut here------------------------------------

;; Calendar window function; copyright (C) 1987, Edward M. Reingold.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  The author accepts no responsibility to
;; anyone for the consequences of using it or for whether it serves
;; any particular purpose or works at all.

;; Everyone is granted permission to copy, modify, and redistribute
;; this function.

;; This notice must be preserved on all copies.

;; Comments, corrections, and improvements should be sent to

;;         Edward M. Reingold
;;         Department of Computer Science
;;         University of Illinois at Urbana-Champaign
;;         1304 West Springfield Avenue
;;         Urbana, Illinois 61801

or via electronic mail to

;;         reingold@cs.uiuc.edu

;; This function requires the Unix programs date and cal.

(defconst month-alist
      '(("Jan" . 1) ("Feb" . 2)  ("Mar" . 3)  ("Apr" . 4)
        ("May" . 5) ("Jun" . 6)  ("Jul" . 7)  ("Aug" . 8)
        ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))
      "association list of months/sequence numbers")

(defun calendar ()
  "Display a calendar of the current month, surrounded by calendars of the
   previous and next months.  The cursor is left indicating the date."
  (interactive)
  (progn
    (set-buffer (get-buffer-create "*Calendar*"))
    (message "Getting calendar...")
    (setq buffer-read-only nil)
    (erase-buffer)
    (call-process-region (point-min) (point-max) "date" t t)
    (goto-char (point-min))
    (re-search-forward
      " \\([A-Z][a-z][a-z]\\) *\\([0-9]*\\) .* \\([0-9]*\\)$" nil t)
    (let ((month
            (int-to-string
              (cdr (assoc (buffer-substring (match-beginning 1) (match-end 1))
                          month-alist))))
          (day (buffer-substring (match-beginning 2) (match-end 2)))
          (year (buffer-substring (match-beginning 3) (match-end 3))))
      (erase-buffer)
      (call-process-region (point-min) (point-max) "cal" nil t nil month year)
      (goto-char (point-min))
      (next-line 2)
      (search-forward day)
      (backward-char 1)
      (make-local-variable 'today)
      (setq today (dot-marker))
      (let ((last-month
              (int-to-string
                (if (string-equal month "1")
                    12
                    (1- (string-to-int month)))))
            (last-month-year
              (if (string-equal month "1")
                  (int-to-string (1- (string-to-int year)))
                  year)))
        (goto-char (point-min))
        (insert "                        ")
        (setq top-right (dot-marker))
        (insert "\n")
        (call-process-region (point-min) (point-min)
                             "cal" nil t nil last-month last-month-year)
        (previous-line 1)
        (setq bottom-left (dot-marker))
        (kill-rectangle (marker-position top-right)
                        (marker-position bottom-left))
        (delete-region (marker-position top-right)
                       (marker-position bottom-left))
        (yank-rectangle))
      (let ((next-month
              (int-to-string
                (if (string-equal month "12")
                    1
                    (1+ (string-to-int month)))))
            (next-month-year
              (if (string-equal month "12")
                  (int-to-string (1+ (string-to-int year)))
                  year)))
        (goto-char (point-min))
        (insert "                        ")
        (setq top-right (dot-marker))
        (insert "\n")
        (call-process-region (point-min) (point-min)
                             "cal" nil t nil next-month next-month-year)
        (previous-line 1)
        (setq bottom-left (dot-marker))
        (kill-rectangle (marker-position top-right)
                        (marker-position bottom-left))
        (delete-region (marker-position top-right)
                        (marker-position bottom-left))
        (goto-char (point-min))
        (next-line 1)
        (insert "                        ")
        (end-of-line)
        (yank-rectangle))
      (goto-char (point-min))
      (next-line 1)
      (delete-region (point) (point-min))
      (setq buffer-read-only t)
      (goto-char (marker-position today))
      (if (= (current-column) 0);; yank-rect spoiled cursor location
          (forward-char 24))
      (switch-to-buffer-other-window "*Calendar*")
      (let ((h (1- (window-height)))
            (l (count-lines (point-min) (point-max))))
        (or (one-window-p t)
            (<= h l)
            (shrink-window (- h l)))))))