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