File psl-1983/3-1/clsc-20/vt52nx.sl artifact 24881d3e52 part of check-in 3af273af29


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


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]