Artifact 59854450c20be42d2bf64d748c570e7f18e9441be8f4f2bb8651ea480129d483:

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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% TELEVIDEO -- Terminal 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 televideo (
  (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 (televideo 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 !=)
      (PBOUT (+ ,row 32))
      (PBOUT (+ ,col 32)))))

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

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

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

(defmethod (televideo move-cursor) (row column)
  % (ROW COLUMN) is the point we want to move to
  (cond ((< row 0) (setf row 0))
	((>= row height) (setf row maxrow)))
  (cond ((< column 0) (setf column 0))
	((>= column width) (setf column maxcol)))
  (let ((relative-move-number-of-chars
	 (+ % vertical move:
	  (cond ((< cursor-row row) (- row cursor-row)) % 1 char to move down
		((> cursor-row row) (- cursor-row row)) % 1 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 to move left
		(T (- column cursor-column)) ) % 1 char to move right
	  )))
    (cond ((= relative-move-number-of-chars 0) ) % no move needed
	  ((and (= row 0) (= column 0))
	   (out-char (CONTROL !^))) % 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 curcol cursor-column (+ column 1) -1)
		       (do (out-char BACKSPACE)) )) % move left
		 (T
		  (for (from curcol cursor-column (- column 1) 1)
		       (do (out-char FF)) )) ) % move right
	   % now take care of the vertical move
	   (cond ((= cursor-row row) ) % no move needed
		 ((< cursor-row row)
		  (for (from currow cursor-row (- row 1) 1)
		       (do (out-char LF)) )) % move down
		 (T (for (from currow cursor-row (+ row 1) -1)
			 (do (out-char (CONTROL K))) )) ) % move up
	   )))
  (setf cursor-row row)
  (setf cursor-column column)
  )

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

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

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

(defmethod (televideo clear-line) ()
  (out-chars ESC (LOWER T))
  )

(defmethod (televideo 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 (televideo normal-enhancement) ()
  (dc-make-enhancement-mask) )

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

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

(defmethod (televideo 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 index of -1, and also avoids cursor movement
    % when the line doesn't need to be changed
    (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)
		  (=> 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))
	(=> 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 (televideo &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 (televideo &set-terminal-enhancement) (enh)
  (setf terminal-enhancement 0) )