home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / muleos2.zip / omake.zip / jcal.el < prev    next >
Lisp/Scheme  |  1994-03-16  |  10KB  |  243 lines
  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. ;;  reingold@a.cs.uiuc.edu           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: cdr@sun.com   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. ;;  fad@think.com
  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 ["$B#17n(B(Jan)" "$B#27n(B(Feb)" "$B#37n(B(Mar)" "$B#47n(B(Apr)" "$B#57n(B(May)" "$B#67n(B(Jun)"
  191.                   "$B#77n(B(Jul)" "$B#87n(B(Aug)" "$B#97n(B(Sep)" "$B#1#07n(B(Oct)" "$B#1#17n(B(Nov)" "$B#1#27n(B(Dec)"]
  192.                   (1- month))))
  193.     (insert-indented (format "   %s %d" month-name year) indent t)
  194.     (insert-indented "$BF|(B $B7n(B $B2P(B $B?e(B $BLZ(B $B6b(B $BEZ(B" 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.  
  243.