;;; -*- Emacs-Lisp -*-

;; Copyright (c) 1990 Massachusetts Institute of Technology
;; 
;; This material was developed by the Scheme project at the Massachusetts
;; Institute of Technology, Department of Electrical Engineering and
;; Computer Science.  Permission to copy this software, to redistribute
;; it, and to use it for any purpose is granted, subject to the following
;; restrictions and understandings.
;; 
;; 1. Any copy made of this software must include this copyright notice
;; in full.
;; 
;; 2. Users of this software agree to make their best efforts (a) to
;; return to the MIT Scheme project any improvements or extensions that
;; they make, so that these may be included in future releases; and (b)
;; to inform MIT of noteworthy uses of this software.
;; 
;; 3. All materials developed as a consequence of the use of this
;; software shall duly acknowledge such use, in accordance with the usual
;; standards of acknowledging credit in academic research.
;; 
;; 4. MIT has made no warrantee or representation that the operation of
;; this software will be error-free, and MIT is under no obligation to
;; provide any services, by way of maintenance, update, or otherwise.
;; 
;; 5. In conjunction with products arising from the use of this material,
;; there shall be no use of the name of the Massachusetts Institute of
;; Technology nor of any adaptation thereof in any advertising,
;; promotional, or sales literature without prior written consent from
;; MIT in each case.

;;;
;;; techinfo.el - Emacs mode for accessing TechInfo database
;;; requires ability to "attach" Athena filesystems
;;;
;;; Author: Brian A. LaMacchia -- bal@zurich.ai.mit.edu
;;;
;;; $Header: /zu/bal/elisp/RCS/techinfo.el,v 1.4 1991/07/24 18:04:03 bal Exp bal $
;;;

(provide 'techinfo)

(defvar techinfo-web-buffer nil
  "Buffer which contains a copy of the TechInfo web file.")

(defvar techinfo-buffer nil
  "Buffer used for displaying TechInfo information.")

(defvar techinfo-current-node-list nil
  "Cached list of web file information for the current node.")

(defvar techinfo-attached-filesystems '()
  "List of filesystems already attached by this run of TechInfo.  If a filesystem name appears in this list subsequent calls to attach will not be made.")

(defvar techinfo-parent-list nil
  "List of parent nodes from this node to the root node.")

(defvar techinfo-history-list nil
  "List of TechInfo nodes previously visited.")

(defvar techinfo-need-to-attach-afs nil
  "True if AFS is not available by default, and the NFS->AFS translator on Atalanta is needed.  At Tech Square this variable is set to t.  At Athena it is nil.")

(defun techinfo-find-line (number)
  (save-excursion
    (set-buffer techinfo-web-buffer)
    (goto-char (point-min))
    (re-search-forward
     (concat "^" number ":"))
    (let ((lb (save-excursion (beginning-of-line) (point)))
	  (le (save-excursion (end-of-line) (point))))
      (buffer-substring lb le))))

(defun techinfo-parse-line (string)
  (let ((the-index (string-match ":" string)))
    (let ((the-list (list (substring string 0 the-index)))
	  (the-old-index (1+ the-index)))
      (while (progn
	       (setq the-old-index (1+ the-index))
	       (setq the-index (string-match ":" string (1+ the-index)))
	       the-index)
	(setq the-list (append the-list (list (substring string the-old-index the-index)))))
      (let ((the-new-string (substring string the-old-index nil)))
	(let ((index1 0)
	      (index2 (string-match "," the-new-string)))
	  (let ((the-num-list (list (substring the-new-string index1 index2))))
	    (if index2
		(progn
		  (while (progn 
			   (setq index1 (1+ index2))
			   (setq index2 (string-match "," the-new-string (1+ index2)))
			   index2)
		    (setq the-num-list (append the-num-list (list (substring the-new-string index1 index2)))))
		  (setq the-num-list (append the-num-list (list (substring the-new-string index1 index2))))))
	    (append the-list (list the-num-list))))))))

(defun techinfo-line/number (techinfo-line)
  (nth 0 techinfo-line))

(defun techinfo-line/unknown2 (techinfo-line)
  (nth 1 techinfo-line))

(defun techinfo-line/unknown3 (techinfo-line)
  (nth 2 techinfo-line))

(defun techinfo-line/unknown4 (techinfo-line)
  (nth 3 techinfo-line))

(defun techinfo-line/title (techinfo-line)
  (nth 4 techinfo-line))

(defun techinfo-line/source (techinfo-line)
  (nth 5 techinfo-line))

(defun techinfo-line/filesystem (techinfo-line)
  (nth 6 techinfo-line))

(defun techinfo-line/filename (techinfo-line)
  (nth 7 techinfo-line))

(defun techinfo-line/parent (techinfo-line)
  (nth 8 techinfo-line))

(defun techinfo-line/children-list (techinfo-line)
  (nth 9 techinfo-line))

(defun techinfo-display-node (node-number)
  (let ((node-list (techinfo-parse-line (techinfo-find-line node-number))))
    (setq techinfo-history-list
	  (cons (techinfo-line/number node-list)
		techinfo-history-list))
    (if (string= (techinfo-line/filesystem node-list) "")
	(techinfo-display-internal-node node-list)
      (techinfo-display-leaf-node node-list))))

(defun techinfo-display-internal-node (node-list)
  (setq techinfo-current-node-list node-list)
  (pop-to-buffer techinfo-buffer)
  (let ((buffer-read-only nil))
    (delete-region (point-min) (point-max))
    (insert-string "\n")
    (insert-string (techinfo-line/title node-list))
    (center-line)
    (insert-string "\n\n")
    (let ((the-children (techinfo-line/children-list node-list))
	  (the-index 0)
	  (this-child))
      (while (not (null the-children))
	(setq this-child (car the-children))
	(setq the-children (cdr the-children))
	(setq the-index (1+ the-index))
	(insert-string
	 (concat 
	  "  " (format "%5d" the-index) " "
	  (techinfo-line/title (techinfo-parse-line (techinfo-find-line this-child)))
	  "\n")))
      (goto-char (point-min)))))
      
(defun techinfo-display-leaf-node (node-list)
  (setq techinfo-current-node-list node-list)
  (pop-to-buffer techinfo-buffer)
  (let ((buffer-read-only nil))
    (delete-region (point-min) (point-max))
    (insert-string "\n")
    (insert-string (techinfo-line/title node-list))
    (center-line)
    (insert-string "\n\n")
    (let ((the-filsys (techinfo-line/filesystem node-list))
	  (the-filename (techinfo-line/filename node-list)))
      (if (not (techinfo-string-memq the-filsys techinfo-attached-filesystems))
	  (progn
	    (if (and (string= the-filsys "afs") techinfo-need-to-attach-afs)
		(call-process "attach" nil nil nil "-n" "-m" "/afs" "-e" "atalanta.mit.edu:/afs")
	      (call-process "attach" nil nil nil "-n" the-filsys))
	    (setq techinfo-attached-filesystems 
		  (cons the-filsys techinfo-attached-filesystems))))
      (insert-file the-filename)
      (goto-char (point-min)))))
    
(defun techinfo-space-DWIM-internal-node ()
  (save-excursion
    (beginning-of-line)
    (if (looking-at "[ ]*\\([0-9][0-9]*\\)")
	(progn
	  (let ((num (string-to-int (buffer-substring (match-beginning 1) (match-end 1)))))
	    (techinfo-goto-node num))))))

(defun techinfo-space-DWIM-leaf-node ()
  (scroll-up))

(defun techinfo-delete-DWIM-internal-node ()
  (techinfo-up))

(defun techinfo-delete-DWIM-leaf-node ()
  (scroll-down))

(defun techinfo-initialize ()
  (if (not (techinfo-string-memq "ti_data" techinfo-attached-filesystems))
      (progn
	(call-process "attach" nil nil nil "-n" "ti_data")
	(setq techinfo-attached-filesystems 
	      (cons "ti_data" techinfo-attached-filesystems))))
  (if (not (get-buffer "*techinfo-web*"))
      (save-excursion
	(setq techinfo-web-buffer (generate-new-buffer "*techinfo-web*"))
	(set-buffer techinfo-web-buffer)
	(insert-file "/mit/ti_data/admin/pips.web")
	(setq buffer-read-only t)))
  (if (not (get-buffer "*TechInfo*"))
      (progn
	(setq techinfo-buffer (generate-new-buffer "*TechInfo*"))
	(switch-to-buffer techinfo-buffer)
	(setq buffer-read-only t)
	(techinfo-mode)))
  (setq techinfo-parent-list '(0))
  (techinfo-display-node 0))


(defvar techinfo-mode-map nil
  "Keymap containing TechInfo commands.")
(if techinfo-mode-map
    nil
  (setq techinfo-mode-map (make-keymap))
  (suppress-keymap techinfo-mode-map)
  (define-key techinfo-mode-map "." 'beginning-of-buffer)
  (define-key techinfo-mode-map " " 'techinfo-space)
  (define-key techinfo-mode-map "d" 'techinfo-top)
  (define-key techinfo-mode-map "g" 'techinfo-goto-node)
  (define-key techinfo-mode-map "n" 'techinfo-next)
  (define-key techinfo-mode-map "p" 'techinfo-prev)
  (define-key techinfo-mode-map "q" 'techinfo-exit)
  (define-key techinfo-mode-map "u" 'techinfo-up)
  (define-key techinfo-mode-map "l" 'techinfo-last)
  (define-key techinfo-mode-map "\177" 'techinfo-delete))

(defun techinfo-mode ()
  "Major mode for viewing information in the TechInfo database.

In an internal node:
Space	Move to node listed on line containing point.
DEL	Move to parent of current node.
g	Move to node specified by number.

In a leaf node:
Space	Scroll forward a page.
DEL	Scroll backward a page.

In all nodes:
.	Move to beginning of buffer.
n	Move to next sibling of this node.
p	Move to previous sibling of this node.
u	Move to parent of this node.

d	Move to root node.

q	Exit TechInfo."
  (kill-all-local-variables)
  (setq major-mode 'techinfo-mode)
  (setq mode-name "TechInfo")
  (use-local-map techinfo-mode-map)
  (set-syntax-table text-mode-syntax-table)
  (setq local-abbrev-table text-mode-abbrev-table)
  (setq case-fold-search t)
  (setq buffer-read-only t))

(defun techinfo ()
  (interactive)
  (if (get-buffer "*TechInfo*")
      (progn
	(switch-to-buffer "*TechInfo*")
	(techinfo-mode))
    (techinfo-initialize)))

(defun techinfo-space ()
  (interactive)
  (if (string= (techinfo-line/filesystem techinfo-current-node-list) "")
      (techinfo-space-DWIM-internal-node)
    (techinfo-space-DWIM-leaf-node)))

(defun techinfo-delete ()
  (interactive)
  (if (string= (techinfo-line/filesystem techinfo-current-node-list) "")
      (techinfo-delete-DWIM-internal-node)
    (techinfo-delete-DWIM-leaf-node)))

(defun techinfo-up ()
  (interactive)
  (let ((parent (car techinfo-parent-list)))
    (if (not (null (cdr techinfo-parent-list)))
	(setq techinfo-parent-list (cdr techinfo-parent-list)))
    (techinfo-display-node parent)))

(defun techinfo-top ()
  (interactive)
  (setq techinfo-parent-list '(0))
  (techinfo-display-node 0))

(defun techinfo-goto-node (num)
  (interactive "NItem number: ")
  (let ((new-node (nth (- num 1) (techinfo-line/children-list techinfo-current-node-list))))
    (if new-node
	(progn
	  (setq techinfo-parent-list (cons (techinfo-line/number techinfo-current-node-list) techinfo-parent-list))
	  (techinfo-display-node new-node)))))

(defun techinfo-string-memq (string list)
  (let ((the-list list)
	(the-result nil))
    (while (not (null the-list))
      (if (string= string (car the-list))
	  (progn
	    (setq the-result the-list)
	    (setq the-list nil))
	(setq the-list (cdr the-list))))
    the-result))

(defun techinfo-next ()
  (interactive)
  (let ((siblings (techinfo-line/children-list (techinfo-parse-line (techinfo-find-line (car techinfo-parent-list))))))
    (let ((rest (techinfo-string-memq (techinfo-line/number techinfo-current-node-list)
				      siblings)))
      (if (and rest (cdr rest))
	  (techinfo-display-node (car (cdr rest)))))))

(defun techinfo-prev ()
  (interactive)
  (let ((siblings (techinfo-line/children-list (techinfo-parse-line (techinfo-find-line (car techinfo-parent-list))))))
    (let ((rest (techinfo-string-memq (techinfo-line/number techinfo-current-node-list)
				      siblings)))
      (if rest 
	  (let ((num (- (length siblings) (length rest))))
	    (techinfo-display-node (nth (- num 1) siblings)))))))

(defun techinfo-exit ()
  (interactive)
  (bury-buffer techinfo-web-buffer)
  (switch-to-buffer 
   (prog1 
       (other-buffer techinfo-buffer)
     (bury-buffer techinfo-buffer))))

(defun techinfo-last ()
  (interactive)
  (if (and (not (null techinfo-history-list))
	   (not (null (cdr techinfo-history-list))))
      (let ((new-node (car (cdr techinfo-history-list))))
	(setq techinfo-history-list (cdr techinfo-history-list))
	(techinfo-display-node new-node)
	(setq techinfo-history-list (cdr techinfo-history-list)))))


;;; Make Emacs automagically byte-compile this file when it is saved.
;;;
;;; Local Variables:
;;; write-file-hooks: ((lambda () (if (fboundp 'auto-compile) (auto-compile))))
;;; End: