reingold@uiucdcsp.cs.uiuc.edu (11/02/87)
I recently saw a terminal that had a built-in calendar feature; on command
it would display a calendar showing the current, previous, and next months--
the cursor would show the current date. For example,
October 1987 November 1987 December 1987
S M Tu W Th F S S M Tu W Th F S S M Tu W Th F S
1 2 3 1 2 3 4 5 6 7 1 2 3 4 5
4 5 6 7 8 9 10 8 9 10 11 12 13 14 6 7 8 9 10 11 12
11 12 13 14 15 16 17 15 16 17 18 19 20 21 13 14 15 16 17 18 19
18 19 20 21 22 23 24 22 23 24 25 26 27 28 20 21 22 23 24 25 26
25 26 27 28 29 30 31 29 30 27 28 29 30 31
This seemed like a useful thing to have in Emacs, so I cobbled together
the following code to simulate it.
Since I am a neophyte Emacs-Lisp hacker, suggestions would be appreciated
about how to improve the code!
--------------------------cut here----------------------------------------
(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"
(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)
(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*"))))reingold@uiucdcsp.cs.uiuc.edu (11/04/87)
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)))))))