reduce-historical/psl-1983/nmode/doc.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Doc.SL - NMODE On-line Documentation
% 
% Author:      Jeffrey Soreff
%              Hewlett-Packard/CRC
% Date:        15 February 1983
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(BothTimes (load objects
		 extended-char
		 fast-vectors
		 fast-strings
		 fast-int
		 stringx))

% External variables:

(fluid '(
	 nmode-current-buffer
	 nmode-current-window
	 doc-obj-list
	 ))

(setf doc-obj-list nil)

% Internal static variables:

(fluid '(view-mode
	 doc-browser-mode
	 doc-browser-command-list
	 doc-filter-argument-list
	 doc-text-file
	 reference-text-file
	 doc-text-buffer))

(setf doc-text-file "SS:<PSL.NMODE-DOC>FRAMES.LPT")
(setf reference-text-file "SS:<PSL.NMODE-DOC>COSTLY.SL")

(de set-up-documentation ()
  (setf doc-text-buffer (buffer-create-default "+DOCTEXT"))
  (insert-file-into-buffer doc-text-buffer doc-text-file)
  (let ((ref-chan (open reference-text-file 'input)))
    (eval (channelread ref-chan))
    (close ref-chan)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Documentation Browser Commands
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(setf view-mode
    (nmode-define-mode
     "View"
     '((nmode-define-commands Read-Only-Text-Command-List)
       (nmode-define-commands Read-Only-Terminal-Command-List)
       (nmode-define-commands Window-Command-List)
       (nmode-define-commands Essential-Command-List)
       (nmode-define-commands Basic-Command-List)
       (nmode-define-commands
	(list (cons (x-char Q) 'select-previous-buffer-command)))
       )))

(setf Doc-Browser-Mode (nmode-define-mode "Doc-Browser" '(
  (nmode-define-commands Doc-Browser-Command-List)
  (nmode-establish-mode Read-Only-Text-Mode)
  )))

(setf Doc-Browser-Command-List
  (list
   (cons (x-char ?) 'doc-browser-help)
   (cons (x-char F) 'doc-filter-command)
   (cons (x-char E) 'browser-edit-command)
   (cons (x-char I) 'browser-ignore-command)
   (cons (x-char N) 'browser-undo-filter-command)
   (cons (x-char V) 'browser-view-command)
   (cons (x-char Q) 'browser-exit-command)
   (cons (x-char SPACE) 'move-down-command)
   ))

(de doc-obj-compare (obj1 obj2)
  (let ((indx1 (doc-browse-obj$index obj1))
	(indx2 (doc-browse-obj$index obj2)))
    (< indx1 indx2)))

(de doc-browser-help ()
  (write-message "Quit Edit Filter uNdo-filter Ignore View"))

(de doc-filter-command ()
  (let ((browser (=> nmode-current-buffer get 'browser))
	(doc-filter-argument-list 
	 (list (prompt-for-string 
		"Search for what string in a command's name or references?"
		""))))
    (=> browser filter-items #'doc-filter-predicate)))

(de doc-filter-predicate (old-name ref-list)
  (let* ((pattern (string-upcase (first doc-filter-argument-list)))
	 (pattern-length (string-length pattern))
	 (name-list (cons old-name 
			  (for (in ref ref-list)
			       (with name-list)
			       (collect (=> (eval ref) name) name-list)
			       (returns name-list)))))
    (for (in name name-list)
	 (with found)
	 (do (when (let ((limit (- (string-length name) pattern-length))
			 (char-pos 0))
		     (while (<= char-pos limit)
		       (if (pattern-matches-in-line pattern name char-pos)
			 (exit char-pos))
		       (incr char-pos)))
	       (setf found t)))
	 (returns found))))

(de apropos-command ()
  (let* ((doc-filter-argument-list 
	  (list (prompt-for-string 
		 "Search for what string in a command's name or references?"
		 "")))
	 (blist (buffer-create "+DOCLIST" doc-browser-mode))
	 (bitem (buffer-create "+DOCITEM" view-mode))
	 (jnk   (if (null doc-obj-list) (set-up-documentation)))
	 (browser
	  (create-browser blist bitem 
			  ["Documentation Browser Subsystem"
			   ""] doc-obj-list #'doc-obj-compare)))
    (=> browser select-item (car doc-obj-list))
    (=> browser filter-items #'doc-filter-predicate)
    (browser-enter blist)
    (doc-browser-help)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% The doc-browse-obj (documentation-browser-object) flavor:
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defflavor doc-browse-obj
  (
   name
   type
   index
   (start-line NIL)
   (end-line NIL)
   (ref-list ())
   )
  ()
  initable-instance-variables
  gettable-instance-variables
  )

(defmethod (doc-browse-obj display-text) ()
  (string-concat (id2string type) ": " name))

(defmethod (doc-browse-obj view-buffer) (buffer)
  (unless buffer 
    (setf buffer (buffer-create-default "+DOCITEM")))
  (=> buffer reset)
  (if (not (and start-line end-line))
    (=> buffer insert-string
	"Sorry, no documentation is availible on this topic.")
    (=> buffer insert-text
	(cdr (=> doc-text-buffer extract-region 
		 NIL (cons start-line 0) (cons end-line 0)))))
  (=> buffer move-to-buffer-start)
  (=> buffer set-modified? nil)
  buffer)

(defmethod (doc-browse-obj cleanup) ()
  NIL)

(defmethod (doc-browse-obj apply-filter) (filter)
  (apply filter (list name ref-list)))