Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!utgpu!water!watmath!clyde!rutgers!iuvax!pur-ee!uiucdcs!uiucdcsp!reingold
From: reingold@uiucdcsp.UUCP
Newsgroups: comp.emacs
Subject: Improved Calendar Window
Message-ID: <77000004@uiucdcsp>
Date: Thu, 3-Dec-87 11:53:00 EST
Article-I.D.: uiucdcsp.77000004
Posted: Thu Dec  3 11:53:00 1987
Date-Received: Sun, 6-Dec-87 21:56:15 EST
Lines: 140
Nf-ID: #N:uiucdcsp:77000004:000:5393
Nf-From: uiucdcsp.cs.uiuc.edu!reingold    Dec  3 10:53:00 1987


Here is an improved version of the calendar function I posted some weeks
ago. The improvement, by Constantine Rasmussen, is the added ability to
take a prefix argument as the offset (in months) from the current date;
this allows one to see future or past three month intervals.

Try -2823 as a prefix argument.

-----------------------------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
;;
;;         reingold@a.cs.uiuc.edu
;;
;; Modified 11/20/87 for month offset arguments
;;  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
;;
;;
;; 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 (&optional month-offset)
  "Display a calendar of the current month, surrounded by calendars of the
   previous and next months.  The cursor is left indicating the date.
   A prefix argument, if any, will be treated as an offset to the present
   month to find the month to display.  In this case the day will be the
   first of the month."
  (interactive "P")
  (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
	((day (or (and month-offset " 1") 
		  (buffer-substring (match-beginning 2) (match-end 2))))
	 (month
	  (int-to-string
	   (cdr (assoc (buffer-substring (match-beginning 1) (match-end 1))
		       month-alist))))
	 (year (buffer-substring (match-beginning 3) (match-end 3))))
      (cond (month-offset
	     (setq month-offset (+ (+ (* (string-to-int year) 12)
				      (- (string-to-int month) 1))
				   month-offset))
	     (setq month (int-to-string (+ (% month-offset 12) 1)))
	     (setq year (int-to-string (/ month-offset 12)))))
      (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))
      (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)))))))