Artifact 118feabdad629aa6bb59261e8e7f594ae010c8071ae80d34365e595032876779:

• File psl-1983/3-1/windows/direct-physical-screen.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: 5877) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Direct-Physical-Screen.SL - Write-Line and Direct-Write Version
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        17 August 1982
% Revised:     20 December 1982
%
% Adapted from Will Galway's EMODE Virtual Screen package.
%
% A physical screen is a rectangular character display.  Changes to the physical
% screen are made using the Write operation.  FULL-REFRESH should be called to
% initialize the state of the display.
%
% 20-Dec-82 Alan Snyder
%   Added cached methods for terminal Convert-Character and Get-Character.
% 17-Dec-82 Alan Snyder
%   Revised for the 9836 to write whole lines at a time, keeping track only
%   of which lines have been modified, or write each character directly,
%   according to the DIRECT? variable.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(BothTimes (load objects))
(CompileTime (load fast-int fast-vectors display-char))

(de create-physical-screen (display-terminal)
  (make-instance 'physical-screen 'terminal display-terminal))

(defflavor physical-screen
  (height                % number of rows (0 indexed)
   maxrow                % highest numbered row
   width                 % number of columns (0 indexed)
   maxcol                % highest numbered column
   cursor-row            % desired cursor position after refresh
   cursor-column         % desired cursor position after refresh
   terminal              % the display terminal
   new-image             % image for next refresh
   row-modified?         % which rows need to be rewritten?
   (direct? T)           % write directly to the terminal
   write-char-method     % terminal's write-char method
   write-line-method     % terminal's write-line method
   move-cursor-method    % terminal's move-cursor method
   get-char-method       % terminal's get-character method
   convert-char-method   % terminal's convert-character method
   )
  ()
  (gettable-instance-variables height width cursor-row cursor-column)
  (settable-instance-variables direct?)
  (initable-instance-variables terminal)
  )

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

% Private Macros:

(defmacro image-fetch (image row col)
  `(vector-fetch (vector-fetch ,image ,row) ,col))
(defmacro image-store (image row col value)
  `(vector-store (vector-fetch ,image ,row) ,col ,value))

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

% Public methods:

(defmethod (physical-screen ring-bell) ()
  (=> terminal ring-bell))

(defmethod (physical-screen enter-raw-mode) ()
  (=> terminal enter-raw-mode))

(defmethod (physical-screen leave-raw-mode) ()
  (=> terminal leave-raw-mode))

(defmethod (physical-screen get-character) ()
  (apply get-char-method (list terminal)))

(defmethod (physical-screen convert-character) (ch)
  (apply convert-char-method (list terminal ch)))

(defmethod (physical-screen normal-enhancement) ()
  (=> terminal normal-enhancement))

(defmethod (physical-screen highlighted-enhancement) ()
  (=> terminal highlighted-enhancement))

(defmethod (physical-screen supported-enhancements) ()
  (=> terminal supported-enhancements))

(defmethod (physical-screen write) (ch row col)
  (when (not (= ch (image-fetch new-image row col)))
    (image-store new-image row col ch)
    (if direct?
      (apply write-char-method (list terminal row col ch))
      (vector-store row-modified? row T)
      )))

(defmethod (physical-screen set-cursor-position) (row col)
  (setf cursor-row row)
  (setf cursor-column col)
  (if direct? (apply move-cursor-method (list terminal row col)))
  )

(defmethod (physical-screen refresh) (breakout-allowed)
  (when (and (not direct?)
	     (not (and breakout-allowed (input-available?)))
	     )
    (for (from row 0 maxrow)
	 (when (vector-fetch row-modified? row))
	 (do
	  (apply write-line-method
		 (list terminal row (vector-fetch new-image row)))
	  (vector-store row-modified? row NIL)
	  ))
    (apply move-cursor-method (list terminal cursor-row cursor-column))
    ))

(defmethod (physical-screen full-refresh) (breakout-allowed)
  (=> terminal erase)
  (when (not (and breakout-allowed (input-available?)))
    (for (from row 0 maxrow)
	 (do
	  (apply write-line-method
		 (list terminal row (vector-fetch new-image row)))
	  (vector-store row-modified? row NIL)
	  ))
    (apply move-cursor-method (list terminal cursor-row cursor-column))
    ))

(defmethod (physical-screen write-to-stream) (s)
  (for (from row 0 maxrow)
       (with line)
       (do (setf line (vector-fetch new-image row))
	   (for (from col 0 maxcol)
		(do (=> s putc (dc-character-code (vector-fetch line col))))
		)
	   (=> s put-newline)
	   ))
  )

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

% Private methods:

(defmethod (physical-screen init) (init-plist) % For internal use only!
  (setf height (=> terminal height))
  (setf maxrow (- height 1))
  (setf width (=> terminal width))
  (setf maxcol (- width 1))
  (setf cursor-row 0)
  (setf cursor-column 0)
  (setf new-image (=> self create-image))
  (setf row-modified? (make-vector height NIL))
  (setf write-char-method (object-get-handler terminal 'write-char))
  (setf write-line-method (object-get-handler terminal 'write-line))
  (setf move-cursor-method (object-get-handler terminal 'move-cursor))
  (setf get-char-method (object-get-handler terminal 'get-character))
  (setf convert-char-method (object-get-handler terminal 'convert-character))
  )

(defmethod (physical-screen create-image) ()
  (let ((image (MkVect maxrow))
	(line (MkVect maxcol))
	)
    (for (from col 0 maxcol)
	 (do (vector-store line col #\space))
	 )
    (for (from row 0 maxrow)
	 (do (vector-store image row (copyvector line)))
	 )
    image))