Path: utzoo!utgpu!watmath!clyde!att!rutgers!cmcl2!nrl-cmf!ukma!gatech!purdue!decwrl!sun!pitstop!sundc!seismo!uunet!mcvax!ukc!harrier.ukc.ac.uk!eagle.ukc.ac.uk!icdoc!qmc-cs!harlqn!jcgs
From: jcgs@harlqn.harlqn.uucp (John Sturdy)
Newsgroups: comp.emacs
Subject: Re: non-editing modes and code
Message-ID: 
Date: 1 Dec 88 12:24:20 GMT
References: <1647@harlqn.UUCP>
Sender: news@harlqn.UUCP
Organization: Harlequin Ltd, Cambridge, England
Lines: 330
In-reply-to: jcgs@harlqn.UUCP's message of 30 Nov 88 15:40:01 GMT

Here's some more stuff not so directly related to editing: it handles
calendar files (a subset of the format taken by Unix's calendar (1)).
There are two sets of functions in this file: one for handling
calendars, and one for finding people. (They go together as we have a
site-wide file calendar.away which says who expects to be away on a
particular day.)
(To use multiple calendar files, use #include. But first check that
your local version of the calendar program puts the users' calendars
through cpp - I think that is a recent development.)
This stuff has grown gradually, there are some functions there I don't
use so much now. The interactive calls to it that I currently use are:
  M-x diary (find a diary file)
  M-x diary-enter (find a place in the current diary file)
  M-x locate (find a person)
I think there is a bug in the construction of search patterns for
dates, but it only turns up for obscure combinations of dates, and I
haven't managed to track it down yet. You may need to adjust the
arguments to "substring" in the "locate" program, to suit your local
version of "rwho".
--------------------------------cut here--------------------------------
;;; calendar.el - niceties for handling *date-sorted* calendar files
;;; Last edited: Thu Dec  1 11:19:22 1988 by jcgs (John Sturdy) on harlqn

(provide 'calendar)

(defun get-date-leading-zero ()
  "Return today's date, with a leading zero for days 1-9 of the month."
  (let ((todays-date (substring (current-time-string) 4 10)))
    (if (string= (substring todays-date 4 5) " ")
        (setq todays-date (concat (substring todays-date 0 4)
                                  "0"
                                  (substring todays-date 5))))
    todays-date))


(defun today ()
  "Set the region to include just all of today's appointments."
  (interactive)
  (widen)
  (let
      ((todays-date (get-date-leading-zero))
       (old-point (point)))
    (goto-char (point-max))
    (if (search-backward todays-date (point-min) t)
        (progn
          (beginning-of-line 2)         ; beginning of next line
          (set-mark (point))
          (goto-char (point-min))
          (search-forward todays-date)  ; was found from bottom, so will now
          (beginning-of-line)           ; find it from top
          t)                            ; say we found it
      (progn                            ; "else": not found, so
        (goto-char old-point)           ;  go back to old point
        nil))))                         ;  and say we didn't find today

(defun show-today ()
  "Narrow to show today's block of appointments in a calendar file.
This can be used as an auto-mode function, on visiting a file with a
name matching \"/calendar$\"."
  (interactive)
  (if (today)
      (progn
        (narrow-to-region (point) (mark))
        (message (substitute-command-keys "\\[widen] to see whole file"))
	t)
    (progn
      (goto-char (point-min))
      (message "No appointments for today")
      nil)))

(defun digit-above-regexp-with-limit (digit limit)
  "Return a regular expression for a digit > DIGIT, for DIGIT <= LIMIT
or if DIGIT is greater than LIMIT, something that will not match any digit."
    (if (> digit limit)
	"[^0-9]"
      (format "[%1d-9]" (1+ digit))))

(defun next-found-day-in-same-month (thereafter)
  "Return a regular expression for the next date string after THEREAFTER
within the same month."
  (let
      (
       (month (substring thereafter 0 3))
       (day-high-digit (string-to-int (substring thereafter 4 5)))
       (day-low-digit (string-to-int (substring thereafter 5 6)))
       )
    (format 
     "%s \\\(%d[%d-9]\\\|[%d-3][0-9]\\\)"
;;     "%s \\\(%d%s\\\|%s[0-9]\\\)"
            month
            day-high-digit
            (min (+ day-low-digit 1) 9)
;; (digit-above-regexp-with-limit day-low-digit 9)
            (min (+ day-high-digit 1) 3)
;; (digit-above-regexp-with-limit day-high-digit 3)
	    )))


(defun next-month (month)
  "Increment a month-string
circularly (ie
 (equal (next-month \"Dec\") \"Jan\")
)."
  (cdr (assoc month
              '(("Jan" . "Feb") ("Feb" . "Mar") ("Mar" . "Apr")
                ("Apr" . "May") ("May" . "Jun") ("Jun" . "Jul")
                ("Jul" . "Aug") ("Aug" . "Sep") ("Sep" . "Oct")
                ("Oct" . "Nov") ("Nov" . "Dec") ("Dec" . "Jan")))))

(defun goto-day-after (date-string)
  "Move point to the beginning of the first line after the date given.
Leaves mark at the old cursor position."
  (interactive "sDate to move after: ")
  (set-mark (point))
  (if (not (re-search-forward (next-found-day-in-same-month date-string)
                              (point-max) t))
      (let* (
             (month (substring date-string 0 3))
             (following-month (next-month month))
             )
        (while (not (or
                     (search-forward following-month (point-max) t)
                     (string= month following-month)))
          (setq following-month (next-month following-month)))))
  (beginning-of-line 1))

(defun diary-enter (day)
  "Move to the end of the last entry for DAY
or just before the first entry for the next date after that that has
any entries, and insert DAY at the start of a line, to make a new
calendar entry for that day.  Completion is done on reading dates, to
make sure you put only valid dates in."
  (interactive (list (read-date)))
  (widen)
  (goto-char (point-max))
  (if (search-backward day (point-min) t)
      (beginning-of-line 2)
    (progn
      (goto-char (point-min))
      (goto-day-after day)))
  (open-line 1)
  (insert day " "))

(defun appointment (day what-to-do)
  "Find your main calendar file, and at DAY enter WHAT-TO-DO
by moving to the end of the last entry for DAY, or just before the
first entry for the next date after that that has any entries,
inserting DAY at the start of a line, to make a new calendar entry for
that day, then inserting the string WHAT-TO-DO at that date."
  (interactive "sMake entry for date: 
sAppointment: ")
  (save-window-excursion
    (find-file (concat my-home-directory "/calendar"))
    (save-excursion
                                        ; I'd like to use save-restriction
                                        ; here, but it's documentation has
                                        ; a caveat about changing the buffer
                                        ; outside the old narrow area!
      (widen)
      (diary-enter day)
      (insert what-to-do)
      (save-buffer nil))))

(defun move-to-today ()
  "Move point to the first line containing today's date
(or the nearest following date), leaving mark at the old point."
  (interactive)
  (set-mark (point))
  (goto-char (point-min))
  (let ((today (get-date-leading-zero)))
    (if (not (search-forward today (point-max) t))
        (goto-day-after today))))

(defvar calendar-files
  '(("away (meetings away, and holidays)" .
     "/jung/usr/local/lib/calendar.away")
    ("meetings" . "/jung/usr/local/lib/calendar.meetings")
    ("deadlines" . "/jung/usr/local/lib/calendar.deadlines")
    ("new arrivals" .
     "/jung/usr/local/lib/calendar.new")
    ;; ("birthdays" . "/jung/usr/local/lib/calendar.birthdays")
    ("personal calendar" . "~/calendar"))
  "Alist of calendar names against file names.")

(defun read-calendar-file-name (&optional extra-list)
  "Read a calendar file name, using (append extra-list calendar-files)
for the completion list - each entry is the name to put on the
completion list, dotted with the actual file name. The file name is
expanded after reading it, so you can put \"~\" substitutions in the file
name given."
  (let ((file-list (append extra-list calendar-files)))
    (expand-file-name
     (cdr (assoc (completing-read "Calendar: " file-list
				  nil t)
		 file-list)))))

(defun diary (calendar-file-name)
  "Find a calendar file, and put point at today's date.
Completion is provided for choosing which file, when called interactively."
  (interactive (list (read-calendar-file-name)))
  (find-file calendar-file-name)
  (verify-visited-file-modtime (current-buffer))
  (widen)
  (move-to-today))

(defvar month-lengths '(("Jan" . 31) ("Feb" . 28) ("Mar" . 31)
                        ("Apr" . 30) ("May" . 31) ("Jun" . 30)
                        ("Jul" . 31) ("Aug" . 30) ("Sep" . 30)
                        ("Oct" . 31) ("Nov" . 30) ("Dec" . 31))
  "alist giving the length of each (named) month.")

(defun one-day (n)
  "Make a string.number pair from N, for completion lists of days."
  (cons (format "%02d" n) n))

(defun all-days (m)
  "Make a completion list of days up to M."
  (if (> m 0)
      (cons (one-day m) (all-days (1- m)))
    nil))

(defun do-months (mm)
  "Make completion lists for all months in MM."
  (if mm
      (cons
       (cons (car (car mm))
	     (all-days (cdr (car mm))))
       (do-months (cdr mm)))
    nil))

(defvar month-days (do-months month-lengths)
  "An alist of the days in each month.")

(defun read-date ()
  "Read a date, using completion, in the format for calendars."
  (let* ((month (completing-read "Month: " month-days nil t))
	 (this-month-days (cdr (assoc month month-days))))
    (concat month " "
	    (completing-read "Day: " this-month-days
			     nil t))))

(provide 'locate)

(defvar terminal-locations
  '(("jung:console" . "the Meeting Room (at jung's console)")
    ("harlqn:console" . "the Machine Room (at harlqn's console)")
    ("wundt:console" . "the Machine Room (at wundt's console)")
    ("wundt:ttyb" . "the Pit (on Paul's terminal)")
    ("harlqn:tty09" . "the Pit (on Andy's terminal)")
    ("penny:ttyv0" . "the Pit (on Penny)")
    ("jung:ttya" . "Andrew and James' room (on Andrew's terminal)")
    ("harlqn:tty04" . "James and Andrew's room (on James's terminal)")
    ("freud:ttya" . "the Nursery (on Fil's terminal)")
    ;; we think it was this when the building was a used as a house!
    ("freud:console" . "the Nursery (at Freud's console)")
    ("harlqn:tty05" . "the Nursery (on John's terminal)")))

(defun locate-terminal (raw-terminal)
  "Return a string describing the location of RAW-TERMINAL."
  (let* ((terminal (substring raw-terminal
			      0 (string-match " " raw-terminal)))
	 (place (assoc terminal terminal-locations)))
    (if place
	(format "in %s" (cdr place))
      (format "to %s" terminal))))

(defvar
  locator-shell-command
  "rwho -a | grep `grep -i %s /etc/passwd | head -1 | sed -e \"s/:.*//\"` | sort +5 | head -1"
  "A shell command to find the terminal on which a given user $!
has most recently been active.")

(defun find-person-locally (person)
  "Try to locate a person who is not thought to be away"
  (message "%s has given no warning of being away today, looking locally..."
	   person)
  (shell-command (format locator-shell-command person) nil)
  (set-buffer (get-buffer "*Shell Command Output*"))
  (goto-char (point-min))
  (end-of-line 1)
  (let ((rwho-string (buffer-substring (point-min) (point))))
    (if (zerop (length rwho-string))
	(format "Can't find %s" person)
  (let* ((terminal (substring rwho-string 9 24))
	 (terminal-location (locate-terminal terminal))
	 (logon-time (substring rwho-string 22 34))
	 (idle-time (if (> (length rwho-string) 35)
			(format ", idle for %s" (substring rwho-string 37))
		      "")))
    (format "%s is logged on %s, since %s%s"
	    person terminal-location logon-time idle-time)))))

; (  (format "%s is probably somewhere around here" person))

(defun find-person-1 (person)
  "Tells you where PERSON is thought to be.
Uses calendar.away to locate them if they are away."
  (save-window-excursion
  (diary "/jung/usr/local/lib/calendar.away")
  (if (show-today)
      (progn
	(goto-char (point-min))
	(if (search-forward person (point-max) t)
	    (progn
	      (beginning-of-line 1)
	      (let ((line-start (point)))
		(end-of-line 1)
		(let ((found (buffer-substring line-start (point))))
		  (widen)
		  (bury-buffer)
		  found)))
	  (find-person-locally person)))
    (find-person-locally person))))

(defun locate (person)
  "Tells you where PERSON is thought to be.
Uses calendar.away to locate them if they are away."
  (interactive "sPerson: ")
  (let ((found (find-person-1 person)))
    (if (interactive-p) (message found))
    found))

;;; end of calendar.el
--------------------------------cut here--------------------------------
--
__John      All facts are useless, but some facts are more useless than others.
                            (After Ecclesiastes Chs. 1 & 2, 1 Corinthians 13:9,
                                             and George Orwell's "Animal Farm")
         jcgs@uk.co.harlqn Harlequin Ltd,Barrington,Cambridge,UK +44-223-872522
                                                 ..!uunet!mcvax!ukc!harlqn!jcgs