Artifact 17d94ca41dc990e08a6adb92323be731ad817d88ccc84d10c5335151e0f53eff:

• File psl-1983/nmode/doc.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5076) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% 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)))