Artifact 24881d3e52e6c11543216b32a2f613332c753c894f4b612995175d0f82a75404:

• File psl-1983/3-1/clsc-20/vt52nx.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: 11119) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% VT52NX -- Non extended VT52 interface
%	    Lon Willett, 6-Jul-83
%	    Based on file:
%
%   TELERAY.SL
%   Author:      G.Q. Maguire Jr., U of Utah
%   Date:        3 Nov 1982
%   based on VT52X.SL by       Alan Snyder
%                              Hewlett-Packard/CRC
%                              6 October 1982
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(BothTimes (load objects))
(CompileTime (load display-char fast-int fast-vectors))
(BothTimes (load JSYS))
(compiletime
 (progn
  (defconst !.MORLW 8#30 % read page width
	    !.MORLL 8#32 % read page length
	    !.PRIOU 8#101) % primary output jfn, it had better be a TTY
% NOTE: since I/O is done with PBIN/PBOUT, using the primary JFN should
% be ok.  This really ought to be written to use an arbitrary JFN.
  (ds get-system-page-height ()
    (jsys3 (const !.priou) (const !.morll) 0 0 (const jsMTOPR)) )
  (ds get-system-line-length ()
    (jsys3 (const !.priou) (const !.morlw) 0 0 (const jsMTOPR)) )
  ))

(defflavor vt52nx (
  (height 24)           % number of rows (0 indexed)
  (maxrow 23)           % highest numbered row
  (width 80)            % number of columns (0 indexed)
  (maxcol 79)           % highest numbered column
  (auto-wrap 'MAYBE)	% does a CRLF when output to last column: YES NO MAYBE
  (auto-scroll 'YES)	% scrolls when output to (MAXROW,MAXCOL): YES NO MAYBE
  (cursor-row 0)        % cursor position
  (cursor-column 0)     % cursor position
  (raw-mode NIL)
  (terminal-enhancement 0) % current enhancement (applies to most output)
  (terminal-blank #\space) % character used by ClearEOL
  )
  ()
  (gettable-instance-variables height width auto-wrap auto-scroll
			       maxrow maxcol raw-mode)
  (initable-instance-variables height width auto-wrap auto-scroll)
  )

(defmethod (vt52nx init) (initlis)
  % Pick up the page length & width from the monitor if it is not
  % specified by an initialization argument.  Use default if we don't like
  % what the monitor claims.
  % HEIGHT & MAXROW:
  (unless (memq 'HEIGHT initlis) (setf height (get-system-page-height)))
  (when (or (< height 10) (> height 96)) (setf height 24))
  (setf maxrow (- height 1))
  % WIDTH & MAXCOL:
  (unless (memq 'WIDTH initlis) (setf width (get-system-line-length)))
  (when (or (< width 10) (> width 96)) (setf width 80))
  (setf maxcol (- width 1)) 
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime
  (defmacro out-char (ch)
    `(PBOUT (char ,ch))))

(CompileTime
  (dm out-chars (form)
    (for (in ch (cdr form))
	 (with L)
	 (collect (list 'out-char ch) L)
	 (returns (cons 'progn L)))))

(CompileTime
  (defmacro out-move (row col)
    `(progn
      (out-chars ESC Y)
      (PBOUT (+ ,row 32))
      (PBOUT (+ ,col 32)))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmethod (vt52nx get-character) ()
  (& (PBIN) 8#177)
  )

(defmethod (vt52nx ring-bell) ()
  (out-char BELL)
  )

(defmethod (vt52nx move-cursor) (row column)
  (cond ((< row 0) (setf row 0))
	((>= row height) (setf row maxrow)))
  (cond ((< column 0) (setf column 0))
	((>= column width) (setf column maxcol)))
  (=> self &move-cursor row column nil nil)
  )

(defmethod (vt52nx enter-raw-mode) ()
  (when (not raw-mode)
    (EchoOff)
    % Enable Keypad?
    (setf raw-mode T)))

(defmethod (vt52nx leave-raw-mode) ()
  (when raw-mode
    (=> self &set-terminal-enhancement 0)
    (setf raw-mode NIL)
    % Disable Keypad?
    (EchoOn)))

(defmethod (vt52nx erase) ()
  % This method should be invoked to initialize the screen to a known state.
  (out-chars ESC H ESC J)
  (setf cursor-row 0)
  (setf cursor-column 0)
  (setf terminal-enhancement NIL) % force resetting when needed
  )

(defmethod (vt52nx clear-line) ()
  (out-chars ESC K)
  )

(defmethod (vt52nx convert-character) (ch)
  (setf ch (& ch (display-character-cons
		  % no enhancements supporeted
		  (dc-make-enhancement-mask
		   % INVERSE-VIDEO BLINK UNDERLINE INTENSIFY
		   )
		  % only font number 0 supported
		  (dc-make-font-mask 0)
		  % only 7 bit chars
		  16#7F)))
  (let ((code (dc-character-code ch)))
    % replace non-printable chars with a space
    (when (or (< code 8#40) (= code (char rubout))) (setf ch terminal-blank)))
  ch)

(defmethod (vt52nx normal-enhancement) ()
  (dc-make-enhancement-mask) )

(defmethod (vt52nx highlighted-enhancement) ()
  (dc-make-enhancement-mask) )

(defmethod (vt52nx supported-enhancements) ()
  (dc-make-enhancement-mask) )

(defmethod (vt52nx update-line) (row old-line new-line columns)
  % Old-Line is updated.

  (let ((first-col (car columns))
	(last-col (cdr columns))
	(last-nonblank-column NIL)
	)
    % Find out the minimal actual bounds:
    (while (and (<= first-col last-col)
	        (= (vector-fetch new-line last-col)
		   (vector-fetch old-line last-col)))
      (setf last-col (- last-col 1))
      )
    (while (and (<= first-col last-col)
	        (= (vector-fetch new-line first-col)
		   (vector-fetch old-line first-col)))
      (setf first-col (+ first-col 1))
      )

    % this check prevents unchecked index of -1, and also keeps
    % us from moving the cursor when the line doesn't need to be updated
    (when (<= first-col last-col)

      % The purpose of the following code is to determine whether or not to use
      % ClearEOL.  If we decide to use ClearEOL, then we will set the variable
      % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to
      % NIL.  If we decide to use ClearEOL, then we will clear out the OLD-LINE
      % now, but do the actual ClearEOL later.

      % Use of ClearEOL is appropriate if the rightmost changed character has
      % been changed to a space, and the remainder of the line is blank.  It
      % is appropriate only if it replaces writing at least 3 blanks.

      (when (= (vector-fetch new-line last-col) terminal-blank)
	(setf last-nonblank-column (vector-upper-bound new-line))
	(while (and (>= last-nonblank-column 0)
		    (= (vector-fetch new-line last-nonblank-column)
		       terminal-blank)
		    )
	  (setf last-nonblank-column (- last-nonblank-column 1))
	  )

	% We have computed the column containing the rightmost non-blank
	% character.  Now, we can decide whether to do a ClearEOL or not.

	(if (and (< last-nonblank-column (- last-col 2)))
	  % then
	  (while (> last-col last-nonblank-column)
	    (vector-store old-line last-col terminal-blank)
	    (setf last-col (- last-col 1))
	    )
	  % else
	  (setf last-nonblank-column NIL)
	  ))

      % Output all changed characters (except those ClearEOL will do):
      (for (from col first-col last-col)
	   (do
	    (let ((old (vector-fetch old-line col))
		  (new (vector-fetch new-line col))
		  )
	      (when (~= old new)
		(let ((new-enhancement (dc-enhancement-mask new))
		      (new-code (dc-character-code new))
		      )
		  % Do we need to change the terminal enhancement?
		  (when (~= terminal-enhancement new-enhancement)
		    (=> self &set-terminal-enhancement new-enhancement)
		    )
		  (=> self &move-cursor row col row old-line)
		  (=> self &print-char new-code)
		  (vector-store old-line col new)
		  )))))

      % Do the ClearEOL, if that's what we decided to do.
      (when last-nonblank-column
	(=> self &move-cursor row (+ last-nonblank-column 1) row old-line)
	(=> self clear-line)
	)
      )))

% The following methods are provided for INTERNAL use only!

% This method outputs a printable character
% (should we check that the character is printable?)
(defmethod (vt52nx &print-char) (ch)
  (cond ((< cursor-column maxcol) % normal case
	 (PBOUT ch) 
	 (setf cursor-column (+ cursor-column 1)))

	((< cursor-row maxrow) % last character on a line, but not last line
	 % This horrendous hack assures that we have auto-wrap
	 (PBOUT ch)
	 (setf cursor-row (+ cursor-row 1))
	 (setf cursor-column 0)
	 (cond ((eq auto-wrap 'NO) (out-chars CR LF)) 
	       ((eq auto-wrap 'MAYBE) (out-move cursor-row 0))
%	       ((eq auto-wrap 'YES) )
	       ))
	(T % Bottom right corner
	 % Prevent scrolling (put blank there if we can't print). Move to (0,0).
	 (IF (or (eq auto-scroll 'YES) (eq auto-scroll 'MAYBE))
	   % THEN
	   (=> self clear-line)
	   % ELSE (eq auto-scroll 'NO) so
	   (PBOUT ch))
	 (=> self move-cursor 0 0) )
	))

(defmethod (vt52nx &move-cursor) (row column known-row-number known-row)
  % (ROW COLUMN) is the point we want to move to
  % KNOWN-ROW-NUMBER is the number of a row whose characters are known, or
  %		     NIL if we don't have a row.
  % KNOWN-ROW is a the vector of chars in KNOWN-ROW-NUMBER
  (let* ((need-to-use-known-line-flag NIL)
	 (relative-move-number-of-chars
	  (+ % vertical move
	   (cond ((< cursor-row row) (- row cursor-row)) % 1 char to move down
		 ((> cursor-row row) (* 2 (- cursor-row row))) % 2 to move up
		 (T 0)) % else no vertical move necessary
	   % horizontal move
	   (cond ((= cursor-column column) 0) % no horizontal move necessary
		 ((= column 0) 1) % move to left column
		 ((> cursor-column column) 
		  (- cursor-column column)) % 1 char / move left
		 ((and known-row-number
		       (let (minumumrow maximumrow)
			 (if (< row cursor-row) 
			   (setf minumumrow row maximumrow cursor-row)
			   (setf minumumrow cursor-row maximumrow row))
			 (and (<= known-row-number maximumrow)
			      (>= known-row-number minumumrow)) ))
		  (setf need-to-use-known-line-flag T)
		  (- column cursor-column)) % can reprint chars, 1/move right
		 (T (* 2 (- column cursor-column))) ) % 2 chars/move right
	   )))
    (cond ((= relative-move-number-of-chars 0) ) % no move needed
	  ((and (= row 0) (= column 0) (>= relative-move-number-of-chars 2))
	   (out-chars ESC H)) % cursor HOME
	  ((>= relative-move-number-of-chars 4)
	   (out-move row column)) % move absolute
	  (T % move relative
	   (cond ((= cursor-column column) ) % no horizontal move needed
		 ((= column 0) (out-char CR)) % move to left-most column
		 ((> cursor-column column)
		  (for (from junk cursor-column (+ column 1) -1)
		       (do (out-char BACKSPACE)) )) % move left
		 ((not need-to-use-known-line-flag)
		  (for (from junk cursor-column (- column 1) 1)
		       (do (out-chars ESC C)) )) % move right
		 (T (while (> cursor-row known-row-number)
		      (out-chars ESC A) % move up
		      (setf cursor-row (- cursor-row 1)) )
		    (while (< cursor-row known-row-number)
		      (out-char LF) % move down
		      (setf cursor-row (+ cursor-row 1)) )
		    (for (from col cursor-column (- column 1))
			 (do (PBOUT (vector-fetch known-row col))) ))
		 )
	   % now take care of the vertical move
	   (cond ((= cursor-row row) ) % no move needed
		 ((< cursor-row row)
		  (for (from junk cursor-row (- row 1) 1)
		       (do (out-char LF)) )) % move down
		 (T (for (from junk cursor-row (+ row 1) -1)
			 (do (out-chars ESC A)) )) ) % move up
	  )))
  (setf cursor-row row)
  (setf cursor-column column)
  )

(defmethod (vt52nx &set-terminal-enhancement) (enh)
  (setf terminal-enhancement 0) )